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[57] 



ABSTRACT 



A symbolic language data processing system comprises 
a sequencer unit, a data path unit, a memory control 
unit, a front-end processor, an I/O and a main memory 
connected on a common Lbus to which other peripher- 
als and data units can be connected for intercommunica- 
tion. The system architecture includes a novel bus net- 
work, a synergistic combination of the Lbus, microtask- 
mg, centralized error correction circuitry and a syn- 
chronous pipelined memory including processor medi- 
ated direct memory access, stack cache windows with 
two segment addressing, a page hash table and page 
hash table cache, garbage collection and pointer control 
a close connection of the macrocode and microcode 
which enables one to take interrupts in and out of the 
macrocode instruction sequences, parallel data type 
checking with tagged architecture, procedure call and 
microcode support, a generic bus and a unique insruc- 
tion set to support symbolic language processing. 

6 Claims, 23 Drawing Sheets 
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1 2 

Through this feature, LISP can incorporate new devel- 

SYMBOLIC LANGUAGE DATA PROCESSING opments in copmuter science. 
SYSXEIM 

LISP frees programmers from the responsibility for 

This application is a continuation of application Ser. 5 ^^^ ^^^^^^ management of memory in the computer. 

No. 450,600, filed 12/17/82, now abandoned. ^^ common FORTRAN and PL/I decisions of how 

big to make a given array or block of memory have no 

BACKGROUND OF THE INVENTION place in LISP. Although it is possible to construct fixed- 

The present invention relates to a data processing size arrays, LISP excels in providing facilities to repre- 

system which is programmable m a symbolic processing ^^ sent arbitrary-size objects, set of unlimited numbers of 

language, in particular LISP. elements, objects concerning which the number of de- 

LISP is a computer programming language which tails or parameters is totally unknown, and so forth. 

originated as a tool to facilitate Artificial Intelligence Antiquated complaints of computers above fixed-size 

research. Artificial Intellignce is a branch of computer 15 data stores ("ERROR, 100 INPUT ITEMS EX- 

science that seeks to imderstand and model mtelligent CEEDED") are eliminated in systems written in LISP, 

behaviorwiththeaidof computers. Intelligent behavior LISP provides an "interactive environment", in 

involves thinking about objects in the environment, which all data (knowledge about what things are and 

how objects relates to each other, and the properties how they are) and functions (knowledge about how to 

and uses of such objects. LISP is designed to facilitate do things) co-exist. Data and functions may be in- 

the representation of arbitrary objects and relationships spected or modified by a person developing a program. 

among them. This design is to be contrasted with that of When an error is discovered in some function or data 

other languages, such as FORTRAN, which are de- object, this error may be corrected, and the correction 

signed to facilitate computations of the values of alge- 25 tested, without the need for a new "run". Correction of 

braic formulae, or COBOL, which is designed to facili- the error and trial of the repair may sometimes be ac- 

tate processing the books and records of businesses. complished in three keystrokes and two seconds of real 

The acronym "LISP" stands for "List Processing time. It is LISP's notion of an interactive environment 

Language", as it was dubbed when Professor John Mc- ^^ which allows both novices and experts to develop mas- 

Carthy of MIT (now of Standford University) invented sive systems a layer at a time. It has been observed that 

LISP in the 1950's. At that time, the notion of represent- LISP experts enter programs directly without need for 

ing data objects and complex relations beween them by "codmg sheets" or "job decks"; the program is written, 

"lists" of storage locations was novel. LISP's motion of entered, and debugged as one operation. Functions can 

"object" has been incorporated into many subsequent ^^ be tested as they are written and problems found. The 

languages (e.g., SIMULA 67), but management believes computer becomes an active participant in program 

that LISP and the languages derived from it are the first development, not an adversary. Programs developed in 

choice of Artificial Intelligence researchers all over the this way build themselves from the groimd up with 

world. 40 solid foundations. Because of these features, LISP pro- 

LISP also facihtates the modeling of procedural gram development is very rapid, 

knowledge (i.e., "how to do something" as opposed to LISP offers a unique blend of expressive power and 

"what something is"). All procedural knowledge is development power. Current applications of LISP span 

expressed as "functions", computational entitites which a broad range from computer-aided design systems to 

"know how" to perform some speciifc action or compu- medical diagnosis and geophysical analysis for oil ex- 

tation upon supplied objects. ploration. Conmaon to these applications is a require- 

Although the text of LISP functions can be from one ment for rapidly constructing large temporary data 

line to several thousand lines long, the language imposes structures and applying procedures to such structures (a 

no penalty for dividing a program mto dozens of hun- 50 data structure is complex configuration of computer 

dreds of functions, each one the "expert" in some spe- memory representing or modeling an object of mterest). 

cific task. Thus, LISP facilitates "modularity", the The power of LISP is vital for such applications. 

clean division of a program into unique areas of respon- Researchers at the M.I.T. Artificial Intelligence Lab- 

sibility, with well-defined interaction. The last twenty oratory initiated a LISP Machine project in 1974 which 

years of experience in the computer science community was aimed at developing a state-of-the art personal 

has established the importance of modularity for cor- computer design to support programmers developing 

rect program operation, maintenance and intelligibihty. complex software systems and in which all of the sys- 

LISP also features "extensible syntax or notation". tem software would be written in LISP. 
This means that language constructs are not limited to 60 The first stage of the project, was a simulator for a 
those supplied, but can include new constructs, defined LISP machine written on a timeshared computer sys- 
by the progranmier, which are relevant to the problem tem. The first generation LISP machine, the CONS, 
at hand. Defining new language constructs does not was running m 1976 and a second generation LISP 
involve modification ofthesuppHed software, or exper- g^ Machine called the CADR incorporated some hard- 
tise in its internal detals, but is a standard feature of the ware improvements and was introduced m 1978, replac- 
language available to the applications (and systems) ing the CONS. Software development for LISP ma- 
programmer, within the grasp of every beginner. chines has been ongoing since 1975. A third generation 
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LISP machine, the LM-2 was introduced in 1980 by mentioned elements and the firmware contained therein 
Symbolics, Inc. achieved the objects of the present invention. In partic- 
The main disadvantages of the aforementioned prior ular, the novel areas of the system include the Lbus, the 
art LISP machines and of symbolic language data pro- synergistic combination of the L-bus, microtasking, 
cessing systems in general, is that the computer hard- centralized error correction circuitry and a synchro- 
ware arclutecture used m these systems was ongmaUy ^^^^ j ^^^^ ^ ^^^^^ ^^^^^^ ^^^.^^^^ 
designed for the more traditional software languages j- . . i ^ - „ 
such as FORTRAN, COBAL, etc. As a result. wUle ^''^''^ '°^'°°^ ^''^''' '"^^ ?^f^ 'T^°'^' "^''^ '^° 
these systems were programmable in symbolic Ian- ^ '"fT f^^T^' ^ P^«* ^^ *^"^ '^^ P^S^ ^^^ 
guages such as LISP, the efficiency and speed thereof ^^^^ ^''''^^' garbage coUection and pointer control, a 
were considerably reduced due to the inherent aspects °^°^ connection of the macrocode and microcode 
of symboHc processing language as explained hereinbe- ^^°^ enables one to take interrupts m and out of the 
fore. macrocode instruction sequences, parallel data type 

SUMMARY OF THE INVENTION '' 2cr!tde"!l'^?'«' architecture, procedure call and 

microcode support, a genenc bus and a unique mstruc- 

The main object of the present invention is to elimi- tion set to support symbolic language processing. 

nate the disadvantages of the prior art data processing The stack caching feature of the present invention is 

systems which are programmable in symbolic languages carried out m the memory controller which comprises 

and to provide a data processing system whose hard- 20 ^^^^ ^^^ ^^^^^^^ ^ ^^^^^^ ^^^^ ^^^^ ^^^ ^^^ ^^ 

ware is particularly designed to be programmable m contiguous main memory addresses in a buffer memory 

symbohc languages so as to be able to carry out data „,i,:^i, „^.«„, ^„+„ ^^ * i * ^ c .- • 

vu «r • J J i_ . i- which stores data of at least one set of contiguous mam 

processmg with an efficiency and speed heretofore un- , , ^ . .^, t eu^ua maiii 

attainable memory addresses and is accessible at a higher speed 

This and other objects are achieved by the system ^^ *^^ ^^^ "^^ "^T""'^' ^^ °'^°'°'^ controller also 

according to the present invention which is preferably comprises means for identifying those contiguous ad- 

programmable in symbolic languages and most advanta- ^^^^^^^ ^ ^^ memory for which data is stored in the 

geously in Zetalisp which is a high performance LISP ^"^^^^ memory and means receptive of the memory 

dialect and which is also programmable in the other 30 ^^i^resses for directly going to the buffer memory and 

traditional languages such as FORTRAN, COB AL etc. ^^^ through the main memory when the identifying 

The system has many features that make it ideally nieans identifies the address as being in the set of contig- 
suited to executing large programs which need high- ^o^s addresses or for going directly to the main mem- 
speed object-oriented symbolic computation. Because o^y and not through the buffer memory when the iden- 
the system hardware and firmware were designed ui "^^ tifying means idenifies the address as not being m the set 
parallel, the basis (macro)instruction set of the system in of contiguous memory addresses- 
very close to pure Lisp. Many Zetalisp instructions The central processor of the system which operates 
execute in one microcycle. This means that programs on data and produces memory addresses, has means for 
written in Zetalisp on the system execute at near the 4^ producing a given memory address corresponding to a 
clock rate of the processor. base pointer and a selected offset from the base pointer 

The present invention is not simply a speeded-up and means for arithmetically combming the given ad- 

version of the older Lisp machines. The system features dress and offset prior to applying same to the addressing 

an entirely new design which results in a processor ^^eans. Further, the central processing means produces 

which IS extremely fast but also reboust and reliable. 45 ^^e base pointer and offset in one timing cycle and arith- 

Tks IS accomphshed through a mynad of automatic ^^tically combines the base pointer and offset in the 

^^Z^r^l^r '" ""in f n .-^ ^^^ t^g -y-l« ^ ^ P^-f^^^d --^er by providing a 
The system processor architecture IS radically differ- -^r. *. T ■ -^ t_- 1. • ^ j. ^ , , f. 
ent from that of conventional systems and the features f^*^'''° ^"^ic umt which « dedicated solely to this 
of the processor architecture include the following: ^^ ^cion. 
Microprogrammed processor designed for Zetalisp Moreover, the addressmg means advantageously 
32-bit data paths comprises means for converting the addresses from the 
Automatic type-checking in hardware cpu to physical locations in main memory by using the 
Full-paging 256 Mword (1 GByte) virtual memory same circuitry as the identifying means. 
Stack-oriented architecture Further, in order to more efficiently carry out these 
oStSf "'^^^"^ '^^""^ ^""^^"^ ^'^^ hardware stack functions, the cpu has means for liming the offset from 
F^t'^Ltraction fetch unit ^^^ ^^^ P°^*^^ *^ ^^*^ ^ preselected range and for 
Efficient hardware-assisted garbage-collection msurmg that the anthmetic combination of the base 
Microtasking ^ pointer and offset fall within at least one set of memory 
5M words/sec data transfer rate addresses. This is advantageously carried out in the 
The system according to the present invention com- compiler which compiles the symbolic processing Ian- 
prises a sequencer unit, a data path unit, a memory guage into sequences of macrocode instructions, 
control unit, a front-end processor, an I/O and a main 55 The parallel data type checking and tagged architec- 
memory connected on a common Lbus to which other ture is achieved by providing the main memory with the 
peripherals and data units can be connected for inter- ability to store data objects, each having an identifying 
communication. The circuitry present m these afore- type field. Means are provided for separating the type 
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field from the remainder of each data object prior to the the failure to locate the physical address in the page 
operation on the data object by the cpu. In parallel with hash table for producing a microcode controlled look- 
the operation on the data object, means are provided for up of the address in the secondary table. 
checking the separated type field with respect to the A further back-up comprises a secondary storage 
operation on the remainder of the associated data object device, for example a disk and wherein the main mem- 
and for generating a new type field in accordance with ory mcludes a third table of addresses and the second- 
that operation. Means thereafter combine the new type ary storage device mcludes a fourth table of addresses, 
field with the results of the operation. This system par- The converting means has means responsive to the 
ticularly advantageously executes each operation on the lo failure to locate the address in the secondary table for 
data object m a predetermined timing cycle and the producing a macrocode controlled look-up of the ad- 
separatmg means, choking means and combining ^^^^ j^ ^^e third table of main memory and then the 
means act to separate, check and combine the new type ^urth table if not in the third table, or mdicating an 
field withm the same tmmig cycle as that of the opera- ,^^, ^f .^ -^ ^^^ ^ ^^ ^^^^^^ ^^^.^^ ^^ 

tion. The system also is provided with means for mter- ^^ ^*i,„r^„*„,^ ^^ -^ ^ i? ^ • .i. ^_i 

. '' ^. /^. . ^ . other feature provides means for entenng the address m 

ruptmg the operation of the data processor m response n r 4.1. * 1.1 1. *u j j ^1 

* *t. J * • J X- ir 1 J xtf . • . J ^ all of the tables where the address was not located. 

to the predetermmed type field that is generated to go ^m, t, j -x r .t. 1 r- ^ ,. , 

into a t^p if the type fieM that is generated is in error or . /^^ ^ardw^e support for the key feature of the close 

needs to be altered, and for resuming the operation of ,0 "^^^^^^^^^^^^P ^^^^^^^ '^^ microcode and mac- 

the data processor upon alteration of the type field. ^° '^^^^ compnses an miprovement m the cpu wherein 

The page hash table feature is carried out in the sys- ^e^^^e f ^^^^^d for defmmg a predetermined set of 
tern wherein the main memory has each location de- exceptional data processor conditions and for detectmg 
fmed by a multi-bit actual address comprising a page *^® occurrence of these conditions during the execution 
number and an offset number. The cpu operates on data 25 ^^ sequences of macrocode instructions. Means are re- 
and stores data in the main memory with an associated sponsive to the detection of one of the conditions for 
virtual address comprising a virtual page number and an retammg a selected portion of the state of the data pro- 
offset number. The page hash table feature is used to ^^^ssor at the detection to permit the data processor to 
convert the virtual address to the actual address and ^^ restarted to complete the pending sequence of mac- 
comprises means for performing a first hash function on ^^ ^^^^^ instructions upon the removal of the detected 
the virtual page number to reduce the number of bits condition. Means are also provided for initiating a pre- 
thereof to form a map address corresponding to the determined sequence of macrocode instructions for the 
hashed virtual page number, at least one addressable detected condition to remove the detected condition 
map converter for storing the actual page number and 35 ^^ restore the data processor to the pending sequence 
the virtual page number corresponding thereto in the ^^ macrocode instructions. In a particularly advanta- 
map address corresponding to the hashed virtual page geous embodiment, the means for initiating comprises 
number and means for comparing the virtual page num- means for manipulating the retained state of the data 
ber with the virtual page number accessed by the map processor to remove the detected condition and means 
address whereby a favorable comparison indicates that ^ ^^^ regenerating the nonretained portion of the state of 
the stored actual page number is in the map converter. ^^^ data processor. 

Means are also provided for performing a second hash "^^ cpu has means for executmg each macrocode 
function on the virtual page number in paralell with that instruction by at least one microcode instruction and the 
of first hash function and conversion and means for 45 means defming the set of conditions and for detecting 
applying the accessed actual page number and the origi- same comprises means controlled by microcode instruc- 
nal offset number to the main memory when there is a tions. Moreover, the means for retaining the state of the 
favorable comparison and for applying the second data processor comprises means controlled by micro- 
hashed virtual page number to the main memory when code instructions and the means for initiating the prede- 
the comparison is unfavorable. ^^ termined sequence of macrocode instructions comprises 

In a particularly advantageous embodiment, the con- means controlled by microcode mstructions. 

verting means comprises at least two addressable map Another important feature of the present invention is 

converters each receptive of the map address corre- the unique and synergistic combination of the Lbus, the 

sponding to the first hashed virtual page number and 55 microtasking, the synchronized pipelined memory and 

means responsive to an unfavorable comparison from the centralized error correction circuitry. This combi- 

ali converters for writing the virtual page number and nation is carried out in the system according to the 

actual page number at the map address in the least re- present invention with a cpu which executes operations 

cently used of the at least two map converters. on data in predetermined timing cycles which is syn- 

In the event that the first and second hashed ad- ^ chronous with the operation of the memory and at least 

dresses do not locate the address, the main memory has one peripheral device connected on the Lbus. The main 

means defining a page hashed table therein addressable memory has means for initiating a new memory access 

by the second hashed virtual page number and a second- in each timing cycle to pipelme data therein and there- 

ary table for addresses. The cpu is responsive to mac- 55 out and the cpu further comprises means for storing 

rocode instructions for executing at least one microcode microcode instruction task sequences and for executing 

instruction, each within one timing cycle and wherein a microcode instruction in each timing cycle and means 

the converting means comprises means responsive to for interrupting a task sequence with another task se- 
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quence in response to a predetermined system condition effect garbage collection in the system by determining 
and for resuming the interrupted task sequence when areas of memory to be garbage collected and wherein 
the condition is removed. The Lbus is a multiconductor the means for producing the action code table produces 
bidirectional bus which interconnects the memory, cpu one action code which initiates the garbage collection 
and peripherals in parallel and a single centralized error sequences. In accordance with the invention, the gar- 
correction ckcuit is shared by the memory, cpu and bage coUection is effected by means for examining the 
peripherals. Means are provided for controUing data data object at a generated address to see if it was moved 
transfers on the bus m synchronism with the system to a new address, means for movmg the data object to a 
tmung cycles to define a first timmg mode for communi- :o new address in a new region if it was not moved, means 
cation between the memory and cpu through the cen- ^^ updating the data object at the generated address to 
tramzed error correction circmt and a second tuning ^^^^^^ ,^^^ ^^ ^^ ^^^^^^ ^^ ^^^^ ^^^ ^^^^^ ^^^ 

mode for commumcation between the penpheral device „«„«^o+«^ ^aa^^.^ *^ « ««„ « ^ j* ^ -^ j i. Tu j * 
, ,. J .V r.. .1. , ^ ^ , , generated address to a new address if and when the data 

and the cpu and thereafter the mam memory through ^u;^„+ • ^^„^a „ j ^-^ w *• *■ .- r .^ 

^, * 11- J ^ • -x T J IS object is moved and for effectmg contmuation of the 

the centrallized error correction circmt. In accordance ^^ *. *i. j . i.- . /..J^ , ,, 

with this combination of features, data is stored in main ^P!!f *^°^ ,^^ '^^ data object of the generated address. 
memory from a peripheral and data is removed from • J^VT"" "^^°^^"^«f '^^ f "^^^* T'"'''"'' ?'t 

main memory for the peripheral at a predetermined ""'^^ . ^^PP^^ for garbage collection which 

location which is based upon the identification of the ,^ ^°^^^^ '' '"! ^f^^^' *^' ^^^^^e collection sequence 
peripheral device. Moreover, the cpu has means for "" ^ particularly efficient manner by dividing the main 
altering the state of the peripheral device from which "'^f °^ "'^^ P^^^ ^^ providing storage means having 
data is received, depending upon the state of the system. ^* ^^^* °"^ ^'^ associated with each page of memory. 

The feature of the generic bus is provided to enable ^^ ^""^^ ^^^^^^ ^ thereafter located in a region of 
the system according to the present invention, having 25 ^aemory and means are provided for entering a code in 
the cpu in main memory connected by a common sys- *^^ ^^ ^^^* ^^^ ^^* ^^^ ^ S^^^^ P^S^ ^ parallel with the 
tem bus to which input and output devices are connect- locating of the address in a region of memory to indi- 
able, to communicate with other peripherals and com- ^^*® whether an address therein is m a selected set of 
puter systems on a second bus which is configured to be regions in memory. 

generic by providing first mterfacing means for con- '^^ means for entering the code comprises means for 

verting data and control signals between the system bus producing a table of action codes each corresponding to 
and the generic bus formats to effect transmission be- ^^^ region of memory. An address is applied to the 
tween the system bus and the generic bus and second ^^^^ and parallel with the locating thereof and means 
interfacing means connected to the generic bus for con- 35 are provided for determining if the address is in one of 
verting data and control signals between the generic bus ^^^ selected set of regions in response to its associated 
and a selected external bus format to permit data and action code. The garbage collection is effected in the set 
control signal transmissions between the system bus and ^^ memory regions by reviewing each page and means 
the peripherals of the selected external bus type. A key sense the at least one bit for each memory page to en- 
feature of this generic bus is that the first mterfacing ^ able the reviewing means to skip that page when the 
means converts data and control signals independently code is not entered therein. 

of the external bus that is selected. Thus the first inter- The bus system in accordance with the present inven- 

facing means includes means for converting the control ^^^^ is another feature of the present invention which, in 
signals and address of an external bus peripheral from 45 the context of the system according to the present in- 
the system bus format to the generic bus format inde- vention includes the data processor alone, the data pro- 
pendently of the control signal and address format of cesser in combination with peripherals and peripheral 
the external bus. units which have the means for communicatmg with the 

The pointer control and garbage collection feature data processor on the Lbus. The data processor includes 
associated therewith is carried out by means for divid- ^^ bus control means for effecting all transactions on the 
mg the main memory mto predetermined regions, bus in synchronism with the data processor system 
means for locating data objects in the regions and means clock and with a timing scheme including a request 
for producing a table of action codes, each correspond- cycle comprising one clock period wherein the central 
ing to one region. A generated address is then applied to 55 processor produces a bus request signal to effect the 
the table m parallel with the operation on that address transaction and within the same clock period puts the 
to obtain the action code associated therewith and address data out on the bus. The request cycle is fol- 
means are provided which are responsive to the action lowed by an active cycle comprising at least one next 
code for determining, in parallel with the operation on clock period wherein the peripheral unit is accessed. 
the address, if an action is to be taken. In a particular ^ The active cycle is followed by a data cycle comprismg 
advantageous embodiment, the action code is obtamed the next clock period and wherein data is placed on the 
and the response thereto is determined within the same bus by the peripheral unit. The bus control means also 
timing cycle as that of the operation on the address. has means defining a block bus transaction mode for 
This is done by controlling the determining means by 55 receiving a series of data request signals from the cen- 
microcode mstructions. tral processor in consecutive clock periods and for 

The cpu includes means for executing a sequence of overlapping the cycles of consecutive transactions on 
macrocode and microcode instruction sequences to the bus. 
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The Lbus control according to the present invention tern of the present invention includes a sequencer SQ, a 

also has means for executing microdirect memory ac- data path unit DP, a memory controller MC, a front end 

cess transfer to achieve communication between a pe- processor FEP an I/O unit and the main memory all 

ripheral device and the cpu and thereafter the main connected in parallel on a common bus called the Lbus. 

memory. In a particularly advantageous embodiment of As is also shown therein, other devices such as periph- 

the present mvention, a single centralized error correc- erals and the like can be connected in parallel along the 

tion circuit is shared by the memory, central processor Lbus. 

and peripheral device and all data transfers over the bus xhe basic system includes a processor cabinet having 

are communicated through the single centralized error lo reserved, color-coded slots are provided on the L bus 

correction circuit. backplane for the DP-ALU, SQ, FEP, lO and IFU- 

Thus, a data unit for use with a data processing sys- j^EM boards. The rest of the backplane is undedicated, 

tern according to the present invention has means with 14 free 36 bit slots on the basic system Plugging a 

therein which is responsive to a tram^action request memory board into an undedicated slot sets the address 

signal on the bus for receivmg address data m a request 15 ^^ ^^^^ ^^^ ^^^^ ^^ ^^ ^^^^^^^^ ^^ ^^^ ^^^^^ ^^^ 

cycle compmmg one system clock penod, means for ^^^ ^^^ ^ .^ ^^^ ^^p ^^ 

accessmg address data m an active cycle compnsmg at , ^ „ i.- u u j • i I- . i_ x i . -. 

,^® , ., • . J c J- always tell which board IS plugged mto what slot It can 

least one system clock penod and for producmg a . n .v . , i. nZZ r. 

. , ^ . , , ^. . 1 1 . J even tell the senal number of the board. 

weight signal when more than one system clock penod ^n ^j ^ ^ , . , ^ . , . „ , 

is necessary and means for applying data to the bus in a 'V ^f ."^*^"^^ ^^^^^ ^^ ^^^^ ^ the system AH board- 
data cycle comprising the next system clock period. [^^t f^^^^^^^^^*^^'^^, are accomplished through the 
The data unit also may comprise means for receiving backplane. An external cable is provided for comiectmg 
request signals in consecutive clock periods and for ^ ^°f f ^^ *° *^^ processor cabmet. 
overlapping the request, active and data cycles for con- 25 While the system accordmg to the present invention 
secutive transactions. ^* physically configured by components in the manner 

A data unit in accordance with the present invention, ^^^ ^^^^ ^ ^^^- *' ^^y ^^ ^^^ ^^^el features of the 

is also able to effect data transfers on the bus in synchro- system have elements thereof on one or more of the 

nism with the system timing cycle under microcode system components. Thus the system components will 

control to effect a micro DMA data transfer. ^° be described with respect to the function of the detailed 

These and other objects, features and advantages of circuitry contained therein followed by the operation of 

the present invention are achieved in accordance with the system features in terms of these circuit functions. 

the method and apparatus of the present invention as SEOUENCER 

disclosed in more detail hereinafter with regard to the 35 _, 

attached appendix including a microcode listing, a lis- ^^ sequencer is shown m block diagram fonn in 
ting of the microcode bits, the microcode compiler, the 

front end processor program, a summary of the list The sequencer controls the operation of the machine, 

implementation language and Hstings of the program *^^^ ^^' ^* unplements the microtaskmg. In canrying this 

array logic devices referred to in the attached system 40 out, it utihzes an 8KX 112 microcode control memory. 

drawings, wherein: Each 112-bit microcode instruction specifies two 

32-bit data sources from a variety of internal scratchpad 

BRIEF DESCRIFnON OF THE DRAWINGS registers. There is normally no need for one to write 

FIG, 1 is a block diagram of the system according to microprograms, since many Zetahsp mstructions are 

the present invention; executed in one microcycle. 

FIG. 2 is a block diagram of the sequencer of FIG. 1; The system micromachine is time-division multi- 

FIG. 3 is a block diagram of the data path of FIG. 1; plexed. This means that the processor performs house- 

FIG. 4 is a schematic of the data path data type tag keepmg operations such as driving the disk in addition 

circuitry; 50 to executing macroinstructions. This has the advantage 

FIG. 5 is a schematic of the data path garbage collec- of providing a disk controller and other microtasks with 

tion circuitry; the fuU processmg capability and temporary storage of 

FIG. 6 is a schematic of the data path trap control the system micromachine. The close couplmg between 

circmtry; the micromachine and the disk controller has been 

FIG. 7 is a block diagram of the memory control of ^^ proven to be a powerful feature. 

*^^' -^^ Up to eight different hardware tasks can be activated. 

FIG. 8 is a data path diagram of the memory control Control of the micromachine typicaUy switches from 

mstruction fetch unit; one ^^^ to another every few microseconds. The fol- 

FIG. 9 is a block diagram of the memory control map ^ lo^jj^g other tasks nm in the system: 

circmtry; Zetalisp emulator task — executes instructions 

FIGS. 10-23 are a schematic of a 5 12 K memory card Disk transfer task— fetches data from main memory 

according to FIG. 1. and loads the disk shift-register; handles timing and 

DETAILED DESCRIPTION OF THE ,, control for the disk sequencing. 

INVENTION Ethernet handshakmg and protocol encodmg and 

decoding, where Ethernet is a local-area-network 

FIG. 1 is a block diagram of the system according to for communication between computer systems and 

the present invention. As shown therein, the basic sys- peripherals, and their users. The physical structure 
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of the Ethernet is that of a coaxial cable connecting 
all the nodes on the network. 
The FEP and microdevices (i.e., those devices ser- 
viced by microcode, such as the disk controller and the 
Ethernet controller) can initiate task switches on their ^ 
own behalf. The task priority circuitry on the sequencer 
board determines the priority of the microtasks. Multi- 
ple microcontexts are supported, eliminating the need 
to save a microtask's context before switching to an- ,q 
other. 

More specifically, the sequencer includes tasks state 
capture circuitry, task state memory for storing the 
tasks state, a task state parity, a task memory output 
register and a task priority circuit which determines the 15 
priority of 16 tasks which are allocated as follows: 
Tasks 8-15 DMA or I/O tasks. Assigned to devices 
during boot time wakeup requests come from 
open-collector bus Imes. 
Task 7 Not used. The task state memory for this task 20 
is available for the FEP to clobber for debugging 
purposes. The only way this can become the cur- 
rent task is by the FEP forcing it. 
Tasks 1, 2, 5, 8 Software. Wakeup requests are in a 
register; bit n can be set by doing a special function. 25 
One of these tasks is the backgroxmd service task 
for all DMA tasks (set up next address and word 
coimt); the others remain unassigned. 
Task 4 Low-speed devices; wakeup request from 

open-collector bus line. 30 

Task 3 FEP service (wakeup settable by FEP) 
Task Emulator, Wakeup request is always true. 
DMA tasks normally only run for 2 cycles per 
wakeup. The first cycle emits the physical address from 
A memory, increments it, does DISMISS, and skims on ^^ 
a condition from the device (e.g. error or end of 
packet). The second cycle decrements the word count 
and skips on the result (into either the normal first cycle 
or a "last" fu-st cycle). The data transfer between device ^ 
and memory takes place over the Lbus under control of 
the memory control. The "last" first cycle is the same as 
normal, but its successor sets a "done" flag and wakes 
up the background service task. It also turns off wake- 
up-enable in the device so more transfers don't try to 45 
happen until the next DMA operation is set up. For 
some devices there is double buffering of DMA ad- 
dresses and word counts, and there are two copies of 
the DMA microcode; each jumps to the other when its 
word count is exhausted. Processing by the background 
service task is intemiptible by DMA requests for other 
devices. 

Tasks 1, 2, 5, 6, the software requested tasks, are only 
useful as lowered-priority continuations of higher-pri- 55 
ority tasks. They would not normally be awakened by 
the Emulator (although START-I/O would do that). 

Wakeup requests for the hardware tasks (8-15) are 
open-collector lines on the bus. These are totally unsyn- 
chronized. Each device has a register which contains a ^ 
3-bit task number and 1-bit taskmg-enable; task numbers 
are assigned to devices according to the desired prior- 
ity. A wakeup in the absence of enable is held until 
enable is turned on. Once a device has asserted its ^5 
wakeup request, it should remain asserted (barring 
changing of enable or the assigned task number) until 
the request is dismissed. The request must then drop an 
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adequate time before the end of that micromstruction 
cycle, so that 2 cycles later it will be gone from the 
synchronizer register and the task will not wake up 
again. 

Delay from wakeup request to clock that finishes the 
first microinstruction of service is 4 to 5 cycles (or about 
a microsecond) if this is the highest priority task and no 
tasking-inhibit occurs. Really high speed devices may 
set their wakeup request 600 ns early. The processor 
synchronizes and priority-encodes the wakeup requests 
and 

Dismissing is different for hardware and software 
tasks. When a hardware task is dismissed it executes one 
additional microinstruction when a software task is 
dismissed it executes two additional microinstructions. 
The hardware task timing is necessary so that a DMA 
task can wake up and run for only two cycles. 

If a dismiss is done when a task switch has already 
been committed, such that the microinstruction after 
the dismiss is gomg to come from a different task, then 
the machine goes ahead and dismisses. This means that 
the succeedmg microinstruction, which would nor- 
mally be executed immediately, will not be executed 
until the next time the task wakes up. This does not 
apply to a task which dismisses as soon as it wakes up, 
such as a typical DMA task; since a task will not be 
preempted by a higher-priority task immediately after a 
task switch, when a task wakes up it is always guaran- 
teed to run for at least 2 cycles. 
Task-switch timing/sequencing is as follows: 
First cycle, first half: 

Prioritize synchronized task requests. Hardware task 
requests are masked out of the priority encoder if 
they are being dismissed this cycle. 
First cycle, second half: 

Selected task to NEXT NEXT TASK Hues. If this 
differs from current task, NEXT TASK SWITCH 
asserted. Fetch state of selected task into TASK 
CPC, TASK NPC, TASK CSP registers. Just 
before clock, decide whether to really switch tasks 
or to stay in the same task, in which case the TASK 
CPC, etc. registers don't matter, and NEXT 
TASK SWITCH is turned off. 
Second cycle, both halves: 

TASK SWITCH asserted. TASK CPC selected onto 
CMEM A: fetch first micromstruction and new 
task. TASK NPC selected into NPC register. CPS 
gets CMEM A which is TASK CPC. TSKC regis- 
ter gets NEXT CPC, NEXT NPC, NEXT CSP, 
and CUR TASK lines. NEXT TASK lines have 
new task nimiber. 
Second cycle, second half: 

Control-stack addressed by NEXT TASK and 
TASK CSP: CTOS gets top of new stack (unless 
switching to emulator and stack empty, gets IFU in 
that case). CSP gets TASK CSP. 
Third cycle, both halves: 

Execute first microinstruction of task. Fetch second 
microinstruction of task. If only wakmg up for 2 
cycles (dismiss is asserted), choose next task this 
cycle (line first cycle above). 
Third cycle, fu*st half: 
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Task memory written from TSKC (save state of old was read into the CTOS register; this came from the 
l^^^'^^^'^itT^^ ^^ ^^^^ ^*^* ^"^^^^^ stack location pointed to by CSP if the previous cycle 

FoS ?^ ^^ ^°' ^^^™ ^' ^^^^- ^^^ ^^"'^ ^^ ^^^^ ^^ 

Execute^'^second microinstruction of task. If only 5 ^«^^^^^"* ^^P and read the next lower subroutine 
woke up for 2 cycles, TASK SWITCH is asserted ^®*^^ address mto CTOS, m case the next cycle also 

and we do not choose another new task this cycle. POPJs. When POPJ goes to the next macroinstruction, 

Another feature of the sequencer circuitry is trap CSP is not decremented and CTOS is loaded with the 
addressing. The sources of traps are mostly on the data address for the macroinstruction after that. 
path board, with the memory control providing the ^^ Trapping forces a "PUSHJ" so that NPC gets saved. 
MAP MISS TRAP. Slow jumps all come from the data Slow-jump does the same, whether or not you wanted 

path board. The sequencer executes normally if no trap it. If we trap out of a POPJ, we change our mind and 

or slow jump condition is present. With regard to the increment CSP rather than decrementing it. CTOS gets 

trap address interpretation: ^^ loaded with the NPC that we saved. 

Bit 12 is the skip bit; Bits 8-11 are the dispatch bits. The control stack may be popped without jumping to 
Bits 0-7 are capable of incrementing. Thus each macro- it by specifying POPJ but not specifying for the control- 
instruction gets 4 consecutive control-memory loca- memory address to come from CTOS. 
tions; although there is a next-address field m the micro- To sum up what happens on the NEXT CSP lines, 
mstruction. It is used for many things and so consecu- 20 which are both the input to the CSP register and the 
tive addressing is often important. It is also possible for address for control-memory, we first ignore tasking to 
most macroinstructions to skip into their consecutive keep things simple: 

addresses (except for the smaU opcodes where this con- in the first half of each cycle, NEXT CSP contains 

flicts with a wired-in trap address). CSP-f 1. 

In order to do a dispatch, it is nexessary to fmd a ^^ Inthesecondhalf of each cycle, NEXT CSP contains 

block of 16 locations (in bits 8-1 1) which are not in use: cSP normally, but contains CSP-l in the event of a 

tins is done either by finding a block of opcodes that popj or CSP+ 1 m the event of a PUSHJ. A POPJ that 

don t use all 4 of their consecutive locations, or by ^^^^^ ^^T INST generates CSP rather than CSP-1. 

IhT^e^i^e) ^^ ^ dispatches that skip at 30 a trap or slow jump generates CSP+ 1, like PUSHJ. 

„.,,'.,, ^. _ , , . The first half is a write and the second half is a read. 

Each task gets 16 locations of control-stack smce T*t.r-*t.icr t. 1 .1. i.- ^ x^-. 1. 

jj « J !*• 1 • ^ i_-x • ^ rT» 1^ the first half of each cycle, the high bits are the 

adders and multiplexors come m 4-bit mcrements. The ^ . 1 • -.i. ^ i_ i^.i. t.- t. J? 

CADR doesn't use the top half of its 32-location stack ^^^j^^^' f the second half the high bits are the next 

much. Really only 15 locations of control-stack may be ^^ '^^,^^ J'^ ^°^ ^'^' ^^^ ^^' '"^^PP^^ ^^'^ '^^ ^^^' 

used, because the memory is written on every cycle ^„,? ', . 

whether or not you PUSHJ ^^^^ pcisnng out of a trapped mstruction, it is neces- 

The CSP register always pomts at the highest valid '^ ^"^ '^* ^^® ^^^ ^^^^ ^^ " ^* ™^ '^ ^^^^ ^^ ^^^^^ 

location in the stack. Thus it contains 17 when the stack ^ ^^^ '^'^^^ ^^^^ ^^^^ ^^ ^^P condition, which 

is empty. We do write-before-read rather than read- '^ ^"^^ ^^^^ ^^^"^ ^^ *^^ ^^ *^^ emulator task. One 

before-write on this machine, however there is pipelin- ^^ ^^^^ (without using the CTOS as the microm- 

ing through the CTOS register. In fact a 1-instruction struction address source) until this condition becomes 

subroutme will work. t™^* 

When the emulator stack is empty (CSP- 17 and the 45 TABLE 1 

emulator task is in control), there is an "extra" stack Microcode Control of Sequencer 

location which contains the next-mstruction address usEQ <i:0> 

from the IFU. POPJmg to this location generates the no function 

NEXT INST signal and refrains from decrementing the 1 pushj (i.e. increment csP) 

stack pointer (leaves it 17 rather than making it 16). 2 dismiss cyent task 

NEXT INST tells the IFU to advance and does one or xS^fidVeXtive^^^^^^ to when the sequencer is stopped. 

two other random things (it clears the stack-adjustment and forced to 1 when a trap or slow jump is taken. 

counter in the data path). ucpcsel<1:0> 

In the first half of each cycle, NPC is written into the 55 ^''^^^^ ^^^^^^ ^'*°°' "^^""^ "*''* microinstruction will be taken, 

J. r i ^- /IT .t , V . ^ , except for bit 12 which may be selected from -COND (skip). 

next free location (for the current task) m the control- naf (next-address-fieid of current instruction) 

stack. This is 1 -f the location CSP points at. NPC USU- 1 CTOS (control-stack or IFU, normally used together with POPJ) 

ally contains 1+ the control-memory address from 2 npc (take-dispatch, restore from trap) 

which the currently-executing microinstruction came. a L^ap or slow jump supplies an address and ignores this field. 

In the second half of each cycle, the top of the con- °" u npc sel 

trol-stack is read into the CTOS register. In the next Selects source for loading npc register. 

cycle, CTOS and CSP will agree with each other. ^"^f^'^-r^u a^ .k- w. it« 

„,- • -L- t , <. ^ ^ NAF modified by dispatch m bits 11:8 

When switchmg tasks, we read from the new task's 1 next cpc + 1 (only the low 8 bits increment) 

stack. gc With SPEC NPC SEL 1 and MAGIC = 3 (or on rev-3 board). 

Note that what happens when we POPJ, results from ? ^?^/'^T^ 5'*'"; V"P^ . i ■ . 

*i- • V • T xi_ 1 L i* i «,«, , . 1 CPC (forced when takmg trap or slow jump) 

the pipelmmg. In the cycle before the PIPJ, the subrou- unaf<13:0> 

tine return address (or IFU next-mstruction address) Next-address field 
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Microcode Control of Sequencer 



These fields also used by data-path: 
UCONDFUNC <1:0> 

nothing 

1 SKIP (CMEM A 12 gets -COND) 

2 (TRAP IF COND) 

3 (TRAP IF -COND) 
U SPEC <4:0> 

30 ARITHMETIC TRAP WITH DISPATCH 
(If trap to address in NAF, bits 1 1-8 

get replaced by high type bits of Abus and Bbus.) 

31 HALT 

Stops the machine after executing this microinstruction. 

32 NPC MAGIC 

Modifies U NPC SEL above, also allows connection between the 
data path and the sequencer (see MICROINSTRUCTION.BITS). 

33 AWAKEN TASK 

Set wakeup for software task selected by U MAGIC < 1:0> 

34 WRITE TASK 

Write task memory from address and data on Obus. 

35 TASK DISABLE 

Forces the current task to be the same in the cycle after 
next as in the next cycle. Because of this pipelining, you 
need to do this function twice in a row before it really 
takes effect. 
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The clocking circuitry shown in FIGS. 35 and 36 25 
effects controls of the tasking of the machine. 

The data path board always gets an ungated clock. 
Decoding of the microinstruction is modulated by NDP 
where necessary. 

NDP is the DR of nop due to taking a trap, nop due 
to the machine waiting (see below), and nop due to the 
machine being stopped, either by the FEP or by a parity 
error or by a halt microinstruction. 

Waiting is a kind of temporary stop. When the ma- 
chine is waiting it continuously executes the same mi- 
cromstrution without side-effects, until either the wait 
condition goes away or it switches tasks (other tasks 
might not need to wait). Upon return from the task 
switch the same microinstruction is executed again. 
Waiting is used to synchronize with the memory and 
IFU; a wait occurs if the data path asks for data from 
memory that hasn't arrived yet not in the temporary 
memory control, if an attempt is made to start a memory 45 
cycle when the memory is busy. If an attempt is made to 
do a microdevice operation when the bus is busy, or if 
the address from the IFU is being branched to (this is 
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the last microinstruction of a macroinstruction) of a 

macroinstruction) and the IFU says that the address is ^^ on the memory-control and sequencer board, gated by 



priority task; when that task dismisses the waiting mi- 
croinstruction will be retried. 

A trap causes a NDP, inhibiting the side-effects of the 
microinstruction, but when a trap occurs, the sequencer 
still runs. The cycle is stretched to double-length so that 
the control-memory address may be changed to the trap 
addresses. Trapping interacts correctly with tasking. 
The cycle is still stretched to double length when 
though the actual control-memory address is not chang- 
ing. The revised contents of the NEXT CPC lines (the 
trap address) gets written into the task-state memory. 
Note that NDP is not valid before the leading edge of 
the clock, and cannot be used to gate the clock. 

In order for the memory control, which needs to 
decide whether to start a memory cycle well in advance 
of the clock, to work, things cannot be be this simple. 
NDP actually consists of an early component and a late 
component. The early reasons for NDP are stable by 
less than 50 ns after the clock and can inhibit the starting 
of a memory cycle. These include the machine being 
halted, LBUS WAIT, and wait due to interference for 
the Lbus. The latter signal is actually a little slower, but 
the memory control sees it earlier than NDP itself does 
and hence stabilizes sooner. 

The late reasons for NDP are always false while the 
clock is de-asserted. After the leading edge of the clock, 
NDP can come on to prevent side-effects of the current 
microinstruction. If a memory cycle has been started, it 
cannot be stopped, however a write will be changed 
into a read. Except when there is a map miss NDP will 
stop it before the trailing edge of the clock. The late 
reasons for NDP are traps, parity errors, and the half 
microinstruction. All hardware errors are late because 
control-memory parity takes too long to check, but it is 
desirable to stop before executing the bad microinstruc- 
tion rather than after, so that wrong parity in control 
memory may be used as a microcode breakpoint mecha- 
nism. 

Control-memory parity is computed quickly enough 
to manage to stop the sequencer clocks (but not quickly 
enough to turn on NDP and distribute it throughout the 
processor— and all the signals that derive from 
NDP— before the leadmg edge of the clock). 

All this is implemented by having a variety of clocks 
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provided (in the previous cycle) was bad. 

The wait decision has to be made during the first half 
of the cycle, because it is used to gate the clock in some 
places. 

A wait causes a NDP, inhibiting side-effects of the 
microinstruction, but only partially inhibits task switch- 
ing in the sequencer. If a task switch was scheduled in 
the previous cycle, i.e. TASK SWITCH is asserted, 
then the sequencer state (CPC, NPC, UIR, CSP) is ^ 
clocked from the new task's state, but the old task's state 
is not saved; thus the current microinstruction will be 
executed again when control returns to this task. If no 
task switch was scheduled, the sequencer state remains 
unchanged and the microinstruction is immediately 
retried. During a wait new task wakeups are still ac- 
cepted and so the wait can be interrupted by a higher- 
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various conditions. 
CLK— the main clock, which never stops. 
SQ CLK — clock for the main sequencer state (CPC, 
NPC, CSP, CUR TASK). This is stopped by 
WAIT unless switching tasks. 
UIR CLK— like SQ CLK but also clocked by single- 
step even if sequencer stepping is not enabled. 
TSK CLK— like SQ CLK but not stopped by WAIT. 
TSK CLK A-IDENTICAL TO TSK CLK; an elec- 
trically separate copy. 
TSKC CLK — clock for the task-state-capture regis- 
ter. Like SQ CLK but always stopped by WAIT. 
The CTOS register is clocked by TSK CLK. It can't 
be clocked by SQ CLK because when the machine is 
waiting for the IFU the new address from the IFU must 
be clocked in. It shouldn't be clocked by CLK because 
when a parity error occurs in the control stack, it is 
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desirable to be able to read this register before it 
changes. 

Table 2 shows clocking conditions (assuming the 
machine is not stopped by the FEP and not stopped by 
an error). 

TABLE 2 



Normally UIR would be set up to source the appropri- 
ate address. 

Trapping (i.e. branching to a special address and 
nop'ification) does not occur if TRAP ENB is zero. 
Note that when trapping is enabled reading the NEXT 



DWTS 


State 


CTDS 


CUR TASK 


NEXT TASK 


Capture OPC 


NOP 


Error 





elk 


elk 


elk 


clk> = 


elk 


elk 


no 


elk 


D— 


elk 


elk 


elk 


elk< 


elk 


elk 


no 


elk 


-W— 


hold 


elk 


hold 


elk> = 


no 


elk 


yes 


elk 


DW- 


hold 


elk 


hold 


elk > = 


no 


elk 


yes 


elk 


-T- 


elk 


elk 


elk 


elk> = 


elk 


elk 


yes 


elk 


I>-T- 


elk 


elk 


elk 


hold 


elk 


elk 


yes 


elk 


-WT- 


hold 


elk 


hold 


elk> = 


no 


elk 


yes 


elk 


DWT- 


hold 


elk 


hold 


hold 


no 


elk 


yes 


elk 


-S 


elk 


elk 


elk 


hold 


elk 


elk 


no 


elk 


D-S 


elk 


elk 


elk 


elk = 


elk 


elk 


no 


elk 


-w-s 


elk 


elk 


elk 


hold 


no 


elk 


yes 


elk 


DW-S 


elk 


elk 


elk 


hold 


no 


elk 


yes 


elk 


-TS 


elk 


elk 


elk 


hold 


elk 


elk 


yes 


elk 


D-TS 


elk 


elk 


elk 


hold 


elk 


elk 


yes 


elk 


-WTS 


elk 


elk 


elk 


hold 


no 


elk 


yes 


elk 


DWTS 


elk 


elk 


elk 


hold 


no 


elk 


yes 


elk 



DISMISS = (task voluntarily going away, after 1 (or 2) more microinstructions) 

W — MC WAIT (NOP this microinstruction and try it again, on demand of memory control) 

T = Trap (Double-length cycle, NOP this microinstruction, take different successor) 

S = TASK SWITCH (next microinstruction from different task) 

State = UIR, NPC, CPC, CSP 

Capture = task-state capture registers 

Error = hardware error registers 
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30 
When the machine is stopped, it is possible to single- 
step the sequencer and the data path either separately or 
together, and to read and write the microinstruction 
register without disturbing any state. This makes it 
possible to save and restore the complete state (save the 
UIR, step just the sequencer to bring all of its state to 
the spy bus, then execute microinstructions to read the 
data-path state). It is possible to run the machine at full 
speed with control-memory disabled, so that the UIR 
doesn't change, to make one-microinstruction scope 
loops. It is also possible to run the data path at full speed 
with the sequencer stopped, which may or may not be 
useful. 

The FEP controls this via the control register on 45 
SQCLKC, which is cleared when the machine is reset: 
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CPC lines isn't too useful since they alternate between 
the normal address and the trap address in every cycle. 
When the sequencer is stopped, the following do not 
change: 

CSP, CPC, NPC, CTOS, CUR TASK 

The following do not change when the sequencer is 
stopped, except that single-stepping changes them re- 
gardless of ENABLE SQ: 



ORUN 


Set to 1 to let the machine run freely 


ISTEP 


Set to then to 1 to clock the machine 


2 ENABLE DP 


If 0, STEP doesn't affect the data path 


3-ENABLE SQ 


If 1, STEP and RUN don't affect the 




sequencer except UIR 


4 ENABLE CHEM 


If 1, UIRfromCMEM, 




else from CMEM WD register 


5 CHEM WRITE 


If 1, write control-memory 


6 ENABLE TRAP 


If 1, trap conditions set nop and change 




cmem address 


7 ENABLE ERRHALT 


If 1, parity error will inhibit RUN 


8 ENABLE TASK 


If 1, enables task scheduling, if the 


9-12 TASK 


task number is forced from these bits 




here 


13 ENABLE WP 


Enable write-pulse to task and control- 


14 


stack memories spare 


15 


spare 



When writing control-memory, CMEM ENB must 
be to inhibit the RAM outputs and trapping must be 
disabled so that the control-memory address is stable. 
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UIR 



If you don't want the UIR to change, you disable 
control memory and store the appropriate value in the 
CMEM WD register, which will then be loaded into 
UIR. 

The task registers are clocked on every clock, regard- 
less of whether the sequencer is running. These are the 
registers after the task memory. The registers before the 
task memory clock only if the state of the sequencer is 
to be saved, i.e. if the sequencer is running or being 
single-stepped is to be saved, i.e. if the sequencer is 
running or bemg single-stepped and MC WAIT is not 
true. All of the main sequencer state registers, including 
the current task, clock only when the sequencer is run- 
ning. The FEP can control whether the task chosen 
when the sequencer is nmning or single-stepping comes 
from the task scheduler or a task number supplied by 
the FEP. 

Lastly the sequencer includes diagnostic circuitry 
including the error half circuit in FIG. 37 and the debug 
history circuit in FIG. 38 which is part of the spy bus 
network. 

The diagnostic interface to the system includes the 
Spy bus. This is an 8-bit wide bus which can be used to 
read from and write to various portions of the 3600 
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processor. The readable locations in the processor 
allow the FEP to "spy" on the operation of the cpu, 
hence the name "Spy bus". Using the Spy bus, the FEP 
can force the processor to execute microinstructions, 
for diagnostic purposes. 

When diagnostics are not running, the FEP uses the 
Spy bus as a special channel to certain DMA devices. 
Normally, the FEP uses the SPy bus to receive a copy 
of all incoming Ethernet packets. It can also set up and 10 
transfer to the Ethernet and read from the disk via the 
Spy bus. 

Table 3 shows the spy functions on the sequencer 
board: 
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TABLE 3 



SPY WRITE CMEMO,l ,13 WD 

Write an 8-bit slice of the CMEM WD register. This register 
is a source of write data for control-memory and also a source 
of micromstructions into UIR when cmem is disabled. 

SPY READ CMEMOa 13 

Read an 8-bit slice of UIR (which typically contains data from 

CMEM). 

SPY WRITE CTL1,2 

Write sequencer control & clock register described above. 

This has two spy functions since it is a 16-bit register; the 

CTLl is the least-significant byte. 

SPY READ NEXT CPC (2 addresses) 

Read NEXT CPC luies, which are the control-memory address in the 

absence of tasking. Allows reading NPC, CTOS, trap address, 

UNAF, 

To read the CPC you must first 

single-step it into the NPC. To control the NEXT CPC selection you 

force a microinstruction into the UIR. 

SPY READ SO STATUS (2 addresses) 

Read error halt conditions as a 16-bit word: 
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15 -ERRHALT 
14 TSK-STOP 

13 CTOS CAME FROM IFU 
12 CMEM (UIR) PAR ERR 
1 1 TASK MEM PAR ERR 
10 CTOS (LEFT) PAR ERR 
9 CTOS (RIGHT) PAR ERR 
8 MICROCODE HALT 



7 AU STOP 

6 MC STOP 

5 BMEM PAR ERR 

4 AMEM PAR ERR 

3 PAGE TAG PAR ERR 

2 TYPE MAP PAR ERR 

1 GC MAP PAR ERR 

(spare) 

SPY READ TASK 

<3:0> are CUR TASK 

SPY READ SQ STATUS2 

More status: 

1-0 are the CTOS parity bits 

SPY READ SO BOARD ID 

Read the board-ID prom (gives serial number, ECO level, etc.) 

Address comes from the U AMRA <4:0> field of UIR 

SPY READ DP BOARD ID 

Read the board-ID prom on the datapath board (the spy address 

is decoded by the sequencer). 

SPY READ OPCl,2 

Reads PC history memory. 

This is a 16 entry RAM where each entry contains a PC in bits 

< 13:0>, bit < 14> == -NOP for that microinstruction, and fait 

<15> = 1 if the next microinstruction came from a different task. 

The OPC memory reads out backwards (i.e. with the sequencer 

stopped, the first read gets you the last instruction executed, the 

next read gets you the instruction before that, etc.) After 16 reads 

it is back in its original state 

Because you can only read this one byte a time (reading either byte 

decrements the address counter) you have to first read all 16 even 

bytes and then read all 16 odd bytes). 
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DATA PATH 

The data path unit is shown in block diagram form in 
FIG. 3 with the various circuit elements shown in the 
block diagram shown in more detail in FIGS. 4-6. 

The data path unit includes the stack buffer, the arith- 
metic logic unit (ALU), the data typing circuitry, the 
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garbage collection circuitry and other related circuit 
elements. 

The A and B memories include the two stack and 
buffers described hereinabove. The A memory is a 
4Kx40 bit memory. The B memory which is a 256 X 40 
bit memory is shown in FIGS. 60-64 and the corre- 
sponding circuitry therefor is shown in FIGS. 65-66. 

Garbage collection circuitry is shown in FIG. 5 and 
trap control, condition dispatch and microinstruction 
decode circuitry is shown in FIGS. 3-6. 

The ALU is used to carry out the arithmetic combi- 
nation of a given address and offset and is dedicated 
solely thereto. As can be seen from the data flow path in 
the block diagram of FIG. 3, the circuitry on the data 
path unit separates the type field from the data object 
and thereafter checks the type field with respect to the 
operation and generates a new type field in accordance 
with the operation. The new type field and the results of 
the operation are combined thereafter. 

The central processing unit (cpu or processor) exem- 
plifies a tagged architecture computer wherein type- 
checking is used to catch invalid operations before they 
occur. This ensures program reliabihty and data integ- 
rity. While type-checking has been integrated into 
many software compilers, the present system performs 
automatic type-checking in hardware, specifically the 
above-mentioned circuitry in the sequencer. This hard- 
ware allows extremely fast type-checks to be carried 
out at run-time, and not just at compile-time. Run-time 
type-checking is important in a dynamic Lisp environ- 
ment, since pointers may reference many different types 
of Lisp objects. Garbage-collection algorithms (ex- 
plained hereinafter) also need fast type-checking. 

Automatic type-checking is supported by appending 
a tag field to every word processed by the cpu. The tag 
field indicates the type of the object being processed. 
For example, by examining the tag field, the processor 
can determine whether a word is data or an instruction. 

With the tagged architecture, all (macro) instructions 
are generic. That is, they work on all data types appro- 
priate to them. There is, for example, only one ADD 
operation, good for fixed and floating-point numbers, 
double-precision numbers, and so on. The behavior of a 
specific ADD instruction is determined by the types of 
the operands, which the hardware reads in the oper- 
and's tag fields. There is no performance penalty associ- 
ated with the type-checking, since it is performed in 
parallel with the instruction. By using generic instruc- 
tions and tag fields, one (macro)instruction can do the 
work for several instructions on more conventional 
machines. This permits very compact storage of com- 
piled programs. 

In the present system a word contains one of many 
different types of objects. Two basic formats of 36-bit 
words are provided. 

One format, called the tagged pointer format, consists 
of an 8-bit tag and 28 bits of address. The other immedi- 
ate number format consists of a 4-bit tag and 32 bits of 
immediate numerical data. (In main memory, each word 
is supplemented with 8 more bits, mcluding 7 bits of 
ECC). 
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Two bits of every word are reserved for list compac- the system instructions are stack-oriented. This means 

tion or cdr-coding. The cdr-code bits are part of a tech- they reqxiire no operand specification, since their oper- 

nique for compressing the storage of Hststructm-es. The ands are assumed to be on the top of the stack. This 

four possible values of the cdr-code are: normal, error, reduces considerably the size of instructions. The use of 

next, and ml. Normal indicates a standard car-cdr list the stack, m combination with the tagged architecture 

element pair, next and nil represent the list as a vector in features, also reduces the size of the mstruction set. 

memory. This takes up only half as much storage as the jhe control stack is formatted mto frames. The 

normal case, since only the cars are stored. Zetalisp frames usually correspond to function entities. A frame 

pnmitives that create Hsts make these compressed cdr- iq consists of a fixed header, followed by a number of 

coded hsts. Error is used to indicate a memory cell argument and local variable slots, followed by a tempo- 

whose address should not be part of a list. ,^ ^^^y^ ^^^ p^^^^^^ ^ ^^^ ^^^^^^^ ^^^^^ ^^^^^ ^^ 

34 data types are directly supported by the processor. ^^t^es in the binding stack. The data stack is provided 

The type-encodmg scheme is as foUows. A Zetahsp to allow you to place Zetalisp objects in it for especially 

pomter is represented m 34 bits of the 36.bit word The ^^ ^^^ ^^^ manipulations. 

other two bits are reserved for cdr-coding. The first a «*j, ^ «+ i, i • * • j • xt. . i i_ rr- 
U-* r *!. -j^ t.-x * J * . rl • Active stacks are always mamtamed m the stack buff- 
two bits of the 34-bit tagged pomter are the pnmary ^,„ u„ *t,« i, -^ Tn, * i u «? • 1 1.- u 
J* * * ^ ij T 1 r*t.- r- 1-1 • J- . .1-^ ers by the hardware. The stack buffers are special high- 
data typmg field. Two values of this field mdicate that ^^^^1 „ ^^ ._ • . . ^u i,- i, i > 

*u^ I'iuuTu^iA ' -^- * f J •* rn *• speed memones mside the cpu which place a process's 

the 32-bits hold an immediate fixed-pomt of floatmg- ^n T i • * • i • . r.. i i^ ^^ 

. , , ,. . .— , „ *1. . ^ * ^" stack mto a qmck access envuronment. Stack buffer 

pomt number, respectively. (The floatmg-pomt repre- • i .• / i. x . ^ . , 

sentation is compatible with the IEEE smdard). The '°^P"l^t>°»^ (e.g., push, pop) are earned out by the 

other two values of the 2-bit field indicate that the next P'^ff i°' "^^ °°.°"' " °"« machme cycle, 

four bits are further data type bits. The remaining 28 bits ^* *^ macromstruction level, the system has no 

are used as an address to that object. The object types 25 general-purpose registers m the conventional sense, as it 

include- ^® ^ stack-onented machine. This means that many in- 

symbols (stored in four parts: print-name, value, func- structions fetch their operands directly from the stack. 

tion, and properly-Ust) Th® *wo IK word stack buffers are provided in order 

lists (cons cells) to speed the execution of Zetahsp programs. The stack 

strings 30 buffers function as special high-speed caches used to 

arrays contain the top portion of the Zetalisp stack. Since most 

flavor instances memory references in Zetalisp programs go through the 

bignu^(arbitrary-precision integers) 3^^^^, the stack buffers provide very fast access to the 

extended floatmg-pomt numbers referenced obiects 

complex numbers 35 retw^ncea objects. 

extended complex numbers ^® ^^^^^ ^^^^^^ ^*°^^ ^^^^^^ P^^es surroundmg the 

rational numbers "current" stack pointer, since there is a high probability 

intervals they will contain the next-referenced data objects. 

coroutines When a stack overflow or underflows the stack buffer, 

compiled code 40 a fresh page of the stack buffer is automatically allo- 

closures cated (possibly deallocating another page). 

lexical closures Another feature of the stack buffers which supports 

high-speed access is the use of hardware-controlled 

The present-system is stack-oriented, with multiple pushdown pointers, elimmating the need to execute 

stacks and multiple stack buffers in hardware. Stacks software mstructions to manipulate the stack. All stack 

provide fast temporary storage for data and code refer- manipulations work m one cycle. A hardware top-of- 

ence associated with programs, such as values bemg ,^^y, ^^^^,^^ ^^ p.^^j^ed for quick access to that loca- 

computed, arguments, local vanables, and control-flow ^^^^^ ^^ ^ ^^^^ 

mformation. . 50 xhe stack buffer has some area thereof which is allo- 

A mam u^ of a stack is to pass argmnents to mstnic ^^,^^ ^ ^ ^^^^^ ,^ ^^^ ^^^^^^ ^^^^ ^^^^ ^^^^ ^^^^. 

^ons mcludmg functions and flavor methods Fast ^^^^^ ^ ,^^ ^^ ^ .^ ^ 1 ^^^^ ^^^^ 

function callmg is cntical to the performance of cpu- ■ xi. * 1 *i. .. • v • xi j _■ xi_- • j 

, , .TM_ ji ^ 7 , ^ IS the stack that is bemg currently used and this wmdow 

bound programs. The use and layout of the stack for • * • * _* r •. xi_ ^ •. i. ^ .t. 

r *: IV • xi_ -1 ^ ^^^^^ ^^'^ pomtsintosomepartof it so that It shadows the words 

function callmg m the system is novel. ru4. • *i -m. -^ • ^^ 

, ^i. ^ . . . , that are m actual memory. The wmdow is addressed by 

In the system, a given computation is always associ- . * jj • t. .-i- • 1 

* ^ vt. -*^ 1 X 1 TT 1-1 ^ two segment addressmg scheme utilizing a stack 

ated with a particular stack group. Hence, the stacks are „^:„x^^ *4 <v*Tn, attt - . a -.u .u 

^ . , • * * 1 A X 1 1- t pointer and an offset. The ALU associated with the 

comZlr ^'''''^'' ^""""^ ^*^^^ ^^^^^' ^°°^^^^^ '^' P°^^^^ -^ ^^^''' '^ ^- 

A control^stack-»contains the lambda bindings, local ^ ^^f^ to address the window in the stack buffer. 

environment, and caller list. ^" ^ ^^^P envuronment, storage for Lisp objects is 
A binding stack—contains special variables and coun- allocated out of a storage area called the heap in virtual 
ter-flow information. memory. Storage must be deallocated and returned 
A data-stack — contains Lisp objects of dynamic ex- 55 automatically to the heap when objects are no longer 
tent (temporary arrays and lists). referenced. In order to manage the dynamic storage 
In the system, a stack is managed by the processor allocation and deallocation, storage manager and gar- 
hardware m the sequencer as set forth above. Many of bage collection routines must be implmented. Garbage 
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collection is the process of finding "unreferenced" ob- 
jects and reclaiming their space for the heap. This space 
is then free to be reallocated. 

The goal of a good garbage collection algorithm is to 
reclaim storage quickly and with a TniniTniim of over- 
head. Conventional garbage collection schemes are 
computationally costly and time-consuming, since they 
involve reading through the entire address space. This 
is done in order to prove that nowhere in the address 
space are there any references to the storage being con- 
sidered for reclamation. The design of the present sys- 
tem includes imique features for hardware assistance to 
the garbage collection algorithms which greatly sim- 
plify and speed up the process. These hardware features 
are used to "mark" parts of memory to be included in 
the garbage collection process, leaving the rest of mem- 
ory untouched- These hardware features include: 

Type fields which indicate pointers 

Page Tag which indicate pages containing pomters to 
temporary space 

Multi-word read instructions which speed up the 
memory scanning. 

The 2-bit type field inserted into all data words by the 
hardware simplifies garbage collection. This field mdi- 
cates whether or not the word contains a pointer, i.e., a 
reference to a word in virtual memory. 

For each physical page of memory there is a bit called 
a page tag. This is set by the hardware when a pomter 
to a temporary space is written into any location in that 
page. When a disk page is read into a main memory 
page and after a garbage-collection cycle, the micro- 
code sets the bit to the appropriate value. When the 
garbage-collector algorithm wants to reclaim some 
temporary space, it scans the page-tag bits in all the 
pages. Smce the page tag memory is small relative to 
the size of virtual memory, it can be scanned rapidly, 
about 1 ms per Mword of main memory that it de- 
scribes. For all pages with the page-tag bit set, the gar- 
bage collector scans all words in that page, looking for 
pointers to "condemned" temporary space. For each 
such pointer it copies out the object pointed to and 
adjusts the pointer. 

Multi-word read operations speed up the garbage 
collection by fetching several words at a time to the 
processor. 

The virtual memory software assists garbage collec- 
tion with another mechansim. If a page with its page-tag 
bit set is written to disk, the paging software will scan 
through the contents of the page to see what it points at. 
The software creates a table recording the swapped-out 
pages which contain pointers to temporary spaces in 
memory. Since the garbage collector checks this table, 
it can tell which pages contain such pointers. This 
knowledge is used to unprove the efficiency of the 60 
garbage-collection process, since only the pages with 
temporary-space pointers are read into memory during 
garbage collection. 

Page Tag Implementation 

The page tag bits are made out of 16K static RAM 
shown in FIG. 149. 

The following mputs exist: 
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LBUSADDR 23:19 



NORMAL ACTIVE L 



LBUS STATE CLK L 
DP SET CG TAG L 



65 



WRITE ACTIVE L 



WRITE PAGE TAG L 
READ PAGE TAG L 



LBUS DEV 4:3 



the physical page to be accessed 

next. 

true if this is an active cycle and 

the page tags are supposed to see 

it. 

the clock gated by LBUS WAIT. 

true during an active cycle if the 

datapath output during the previous 

cycle was a pointer and its address 

was in a temporary space. If this 

active cycle is for a virtual 

write, the GC tag bit needs to be 

set. 

true during an active write cycle 

(registered version of LBUS WRITE 

L). 

true if Ibus-dev-write of the 

page tag being done. 

true if reading page tag 

(via Ibus-dev-write). 

modifiers for the above. 



Note: 

the spec and magic fields could be used instead of the microdevice I/O. 



The following outputs exist: 



LBUS DEV COND L 



PAGE TAG PAR ERR L 



Asserted when READ PAGE 

TAG and the selected tag 

bit is set. 

asserted when bad parity 

is read from the page 

tags. 



Microcode control: 

One selects a physical page by doing a read of any 
location in the page. Normally the address would be 
supplied as a physical address on the Abus although the 
VMA could also be used. Actually starting a read isn't 
necessary; it's only necessary to convince the memory 
control to put the physical address on the Lbus. In the 
next cycle one uses a microdevice operation to read or 
write the page tage for the addressed page. 

Since the address is supplied in the previous cycle 
before the read and write, it is necessary to prevent a 
task switch from intervening. This is done by specifying 
SPEC TASK-INHIBIT in the microinstruction-before- 
the one that emits the address on the Abus. It is also 
possible for a FEP memory access to intervene between 
the two microinstructions, i.e. the microdevice opera- 
tion may have to wait for the Lbus to become free. The 
page tag's address register is not clocked when MC 
WIAT is asserted, which takes care of this problem. 

WRITE PAGE TAG L is asserted during second 
half when writing to microdevice slot 36, subdevice 1 
(on the FEP board). 

LBUS DEV 3 is written into the selected bit. The 
other remains unchanged. 

LBUS DEV 4 selects which bit: 



the go tag bit 
the referenced bit 



READ PAGE TAG L is asserted when writmg to 
microdevice slot 36 subdevice 3. 
LBUS DEV 4:3 select the bit to read, as follows: 
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00 


the gc tag bit 


01 


the referenced bit 


10 


the parity bit 


11 


(not used) 



10 
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30 



35 



The preselected bit comes back on the LBUS DEV 
COND L line and may be used as a skit condition. 

Scanning GC page tag takes place at the rate of 2 
cycles per bit. This amounts to 1 millisecond per 750 K 
of main memory. The microcode alternates between 
cycles which emit a physical address on the Abus, start 
a read, and do a compare to check for being done, and 
cycles which increment the physical address and also 
skit on the tag bit, into either the first cycle again or the 
start of the word scanning loop. 

There is no special function for writing a pointer into 
main memory to enable the check and setting of gc page 20 
tag. Instead, any write into main memory at a virtual 
address, where the data type map says the type is a 
pointer, and the gc map says it points at temporary 
space, will set the addressed gc page tag bit in the fol- 
lowing cycle if necessary. 

The STKP, FRMP, and XB AS registers can be used 
to address A-memory. The low 10 bits of one of these 
registers is added to a sign-extended 8-bit offset which 
comes from the microinstruction or the macroinstruc- 
tion. This is then concatenated with a 2-bit stack bas 
register to provide a 12-bit A-memory address. The 
microcode can also select a 4th pseudo base register, 
which is either FRMP or STKP depending on the sign 
of the macroinstruction offset. Doing this also adds 1 to 
the offset if it is negative. Thus you always use a posi- 
tive or zero offset with FRMP and a negative or zero 
offset with STKP in this mode, 

STKP points at the top of the stack. FRMP points at 40 
the current frame. 

STKP may be incremented or decremented indepen- 
dently of almost everything else in the machine, and 
there is a 4-bit counter which clears at the beginning of 
a macroinstruction and increments or decrements simul- 
taneously with STKP; this allows changes by pulse or 
minus 7 to STKP to be undone when a macroinstruc- 
tion is aborted (polsred). 

STKP and FRMP are 28-bit registers, holding virtual 50 
addresses, and may be read onto the data path. XBAS is 
only a 10-bit register and may not be read back. (The 
FEP can read it back by using it as a base register and 
seeing what address develops). The XV AS register is 
not used by most of the normal microcode, but it is 
there as a provision for extra flexibility. The microcode 
which BLTs blocks of words up and down in the stack 
(used by fimction return, for example), needs two point- 
ers to the stack. It currently uses FRMP and STKP, but 
might be changed to use XBAS and STKP. The funcall 
(function call with variable function) microcode uses 
XBAS to hold a computed address which is then used 
to access the stack. 

Interface with Memory Control board 

The data path and the memory control need to com- 
municate with each other for the following operations: 



Reading the VMA and PC registers into the data 
path. 

Writing the VMA and PC registers from the data 
path. 

Accessing the address map (at least writing it). 

Reading main memory or memory-mapped I/O de- 
vice. 

Writing main memory or memory-mapped I/O de- 
vice. 

Emitting a physical address (espcially in a "DMA'* 
task). 

Using the bus to access devices such as floating-point 
unit and doing "microdevice" (non-memory-mapped) 
I/O. 

Setting the GC page tag bit when the pointer is writ- 
ten into memory. 

The MC does its own microinstruction decoding. 
There is a 4-bit field just for it, and it also looks at the 
Spec, Magic, A Read Address, and A Write Address 
fields. The A address fields have 9 bits each available 
for the MC when the source (or destination) is not A- 
memory, which is normally the case when readmg (or 
writing) the MC. Also the A-memory write address can 
be taken from the read address field, freeing the write 
address field for use by the MC. This occurs during the 
address cycle of a DMA operation, which increments 
an A-memory location but also hacks the MC. The MC 
and the sequencer also have a good deal of communica- 
tion, mostly for synchronization and for the IFU. 

The following signals connect between the DP and 
MC boards: 
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BK ABUS 



45 



LBUS 35:0 



LBUS ADDR 11:0 
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MC OBUS TO 
LBUSL 
MC OBUS REG 
To LBUS L 
GC TEMP L 



MC ADDR IN 
AMEML 



35:0 - bidirectional extension of the data 
path's Abus. This is used to read VMA, 
PC, map, and memory (or bus) data into 
the data path, and to emit physical 
addresses from the data path. Bits 31-0 
are bidirectional, but bits 35-32 are 
unidirectional, they always go from the 
memory control to the data path; this 
allows the cdr code of a memory location 
to be merged into the data to be stored 
into it, which needs to be on the Abus 
so it can get to the type and gc maps. 
The parity bits on the internal Abus do 
not connect to the MC. 
the main data bus. The data path can 
drive this either directly or through a 
register. This is used when writing main 
memory, when writing the bus, and when 
writing registers on the MC board. The 
error-correction bits do not connect 
to the DP. 

physical memory address into the data 
path. This is used when a supposed main 
memory access actually refers to internal 
A memory. See below. 
DP result from this cycle drives LBus. 

DEP result from last cycle drives 
LBUS 

to GC page tag bits. If this is asserted at 
the end of a cycle which writes into main 
memory, then during the following cycle, 
which is when the write actually happens, 
the GC page tag bit for the page being 
written into its turned on. 
Asserted if the last memory address 
selected by this task (need only work for 
emulator) points at A-memory. The data 
path uses this to enable A-memory instead 
of BK ABUS for memory reads, and to 





enable A-memory writing for memory 




writes. See below. 


ABUS OFFBOARD 


Asserted if the BK ABUS is an input to 


L 


the data path. The DP drives the BK 




ABUS whenever it isn't receiving it. 


SEQUENCE 


Tells the IFU to generate a bogus 


BREAK 


mstruction to take the sequence break 




(macrocode interrupt). 
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■continued address must be set up so that when the operation rou- 

tine returns, it returns to another quick external routine 
which moves the result to the right place. 

Stack buffers traps occur when there is a stack buffer 
overflow. The trap routine does the necessary copying 
between the stack buffer and the main memory. It is 
handled as a trap to macrocode rather than being en- 
tirely m microcode, because of the possiblity of recur- 
The data path assumes that when a memory reference ^^ ^^^^ ^^^P®' ^^®" refilling the stack buffer it is possible to 
is redirected to A-memory, the memory control will envoke the transporter and take page faults. When emp- 
provide the right address on the Lbus address lines. ^V^S *^® ^^^^ buffer, it is possible to get unsafe pointer 

For writing, things are simple. In the furst cycle, the ^^^P^- 
data path computes to write data; in the second cycle 15 MEMORY CONTROL 

the write data is driven onto the Lbus, where it gets 

error-correction bits added. The memory card swal- . The memory control is shown in block diagram form 
lows the address at the end of the furst cycle and the ^^ ^^*^^' '^'^ ^^^?^ ^^°^ ^^® ^^^ ^^ ^"^or correction 
data during the second. The A-memory wants to the ckcuitry in FIG. 7, the data path flow of the instruction 
same timing; in the first cycle the address comes from 20 fetch unit in FIG. 8 and the page hash table mapping in 
the Lbus and the data come from the Obus inside the ^^^' ^• 

data path; in the second half of the second cycle the Physical memory is addressed in 44-bit word units, 

actual write is performed from the A-memory pipelin- ^^s includes 36 bits for data, 7 bits for error correction 
ing registers. code (ECC) plus one bit spare. Double-bit errors are 

The trap control circuitry of FIG. 46 effects the fea- automatically detected, while single-bit errors are both 
ture of trapping out of macrocode instruction execu- detected and corrected automatically. The memory is 
tion. For example a page table miss trap to microcode implemented using 200-ns 64 K bit dynamic RAM (ran- 
looks in the page hash table in main memory. If the page dom access memory) chips with a minimum memory 
is found, the hardware map is reloaded and the trap 30 configuration of 256 Kwords (1MByte) (See FIGS, 
micromstruction is simply restarted. A PCLSR of the 10-23). The write cycle is about 600 ns (three bus cy- 
current instruction happens only if this turns into a fault cles). In some cases the system can get or set one word 
because the page is not in main memory or a page write- per cycle (200 ns), and access a word in 400 ns. 
protected fault -The system 28.bit vutual address space consists of 16 

Another trap is where there is an invisible pointer. 35 ^^^^^ (16,777,216) 44.bit wide words (36-bits of data 
This trap to microcode follows the invisible pointer, and 8 bits of ECC and spares). This address space is 
changmg the VMA and retnes the trap to microinstruc- divided into pages, each containing 256 words. The 

w^^ .^ , •+ * • 1 J I.- i_ . ^ ^PP®^ 20 bits of a virtual address are called the Virtual 

Memory wnte traps mclude one which is a trap for ^ p^^« xr,,«,i,^^ n7r>xn ^ +u • • o u*. i. 

storing a pointer to the stack, which traps to microcode "" ^'f, ^^T)'' Z^^. the remammg 8 bits are the 
that mamtains the stack GC tables. This trap aborts the ^^ ""^'f ^^*^ '^' ^^^'\ ^'"^f"' ^^^^^^^ ^^^^ 
foUowing micro instruction, thus the trapped write "^^'^^^f^ ^^^^^ are always done in pages. The 
completes before the trap goes off The trap handler ''^^! '^^''°^ summarizes the operation of the virtual 
looks at the VMA and the data that was written into 45 ^^^^ apparatus. 

memory at that address, makes entries in tables and then ^^ """^^ "'^'^''^ '""^^"^^ '^ implemented via a 

restarts the aborted microinstruction. If it is necessary ^ombmation of ZetaHsp code and microcode. The labor 
to trap out to microcode, there are two cases. If the *^ "^^""'^^^ ^^^ P^^'^^®^ ^^ mechanisms. Policies are 
write was at the end of a macroinstruction, then that realized m Zetalisp; these are decisions as to what the 
instruction has completed and the followmg instruction ^^ P^^^' ^^®" *° P^^e it, and where to page it to. Mecha- 
has not started since its first microinstruction was ^^^® ^^ realized in microcode; these constitute deci- 
aborted by the trap. However, the program counter has ^^^^^ ^^.*° *^^^ ^° implement the poUcies. 
been incremented and the normal PCLSR mechanism Zetalisp pointers contain a virtual address. Before the 

will leave things in exactly the right state. The other 55 liardware can reference a Zetahsp object, the virtual 
cases where the write was not at the end of a macroin- address must be translated mto a physical address. A 
struction, in this case the instruction must be PCLSR, physical address says where in main memory the object 
with the state in the stack and the furst part done flag. is currently residing. If it is not already m main memory, 
Another trap is a bad data type of trap and an arith- it must either be created or else copied into main mem- 
metic trap wherein one or both of the operands of the ^ o^Y from secondary memory such as a disk. Main mem- 
numbers on which the arithmetic operations is taking ory acts as a large cache, referencmg the disk only if the 
place is a kind of number that the microcode does not object is not already in main memory, and then attempt- 
handle. The system furst coerces the operands to a uni- ing to keep it resident for as long a it will be used, 
form type and puts them in a uniform place on the stack. 55 In order to quickly and efficiently translate a virtual 
Thereafter a quick external macrocode routing for address into a 24-bit physical address, the system uses a 
doing this type of operation on that type is called. If the hierarchy of translation tables. The upper levels in the 
result is not to be returned to the stack, an extra return hierarchy are the fastest, but since speed is expensive 
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they also can accommodate the fewest translations. The 
levels used are: 
Dual Map Caches which reside in and are referenced 
by the hardware and can each accommodate 4 K 
entries. ^ 

A Page Hash Table Cache (PHTC) which resides in 
wired main memory and is referenced by the mi- 
crocode with hardware assist. The size of the 
PHTC is proportional to the niunber of main mem- 
ory pages, and can vary from 4 to 64 Kwords, 
requiring one word per entry. However, the table 
is only 50% dense to permit a reasonable hashing 
performance. 
A Page Hash Table (PHT) and Main Memory Page 
Table (MMPT) which reside in wired main mem- 
ory and are referenced by Zetalisp. The size of 
both of these tables are proportional to the number 
of main memory pages, with the PHT being 75% 
dense and the MMPT 100% dense. Both tables 
require one word per entry. The PHT and MMPT 
completely describe all pages in main memory. 
The Secondary Memory Page Table (SMPT) de- 
scribes all pages of disk swapping space, and dy- 
namically grows as more swapping space is used. 25 
A virtual address is translated into a physical address 
by the hardware checking the Map Caches for the vir- 
tual page number (VPN). If found, the cache yields the 
physical page number the hardware needs. If the VPN 
isn't in the Map Cache, the hardware hashes the VPN ^^ 
into a PHTC index, and the microcode checks to see if 
a valid entry of the VPN exists. If it does, the PHTC 
yields the physical page number. Otherwise a page fault 
to Zetalisp code is generated. 35 

The page fault handler checks the PHT and MMPT 
to determine if the page is in main memory. If so, the 
handler does whatever action is required to make the 
page accessible, loads the PHTC and the least recently 
used of the two Map Cache, and returns. If the page is "^ 
not in main memory, the handler must copy the page 
from disk into a main memory page. When a page fault 
gets to this point it is called a hard fault. A hard fault 
must do the following: 45 

1. Find the virtual page on the disk by looking up the 
VPN in the SMPT. 

2. Fmd an available page frame in main memory. An 
approximate FIFO (first-m, first-out) pool of available 
pages is always maintained with some pages on it. When ^^ 
the pool reaches some minimum size a backgroimd 
process fills it by making the least recently used main 
memory pages available for reuse. If the page selected 
for reuse was modified (that is, its contents in main 55 
memory were changed so the copy on disk is different) 

it must be first copied back to disk prior to its being 
available for reuse. The background process minimizes 
this occurrence at fault time by copying modified pages 
back to the disk periodically, especially those ehgible ^ 
for reuse. 

3. Copy the disk page into the main memory page 
frame. 

4. If the area of the virtual page has a "swap-in quan- ^5 
turn" specified, the next specified number of pages are 
copies into available main memory page frames as well. 

If these prefetched pages are not referenced within 



some interval and some page frames are needed for 
reuse, their frames will be reused. This minimizes the 
impact of prefetching unnecessary pages. 

5. Update the PHT, MMPT, PHTC, and least re- 
cently used of the two Map Cache to contain the page 
just made resident, and forget previous page whose 
frame was used. 

6. Return from the fault and resume program execu- 
tion. 

The central Memory Control unit manages the state 
of the bus and arbitrates requests from the processor, 
the instruction fetch unit, and the front-end processor. 

LBUS 

For general communication with devices, the L bus 
acts as an extension of the system processor. Main mem- 
ory and high speed peripherals such as the disk, net- 
work, and TV controllers and the FEP are interfaced to 
the L bus. The address paths of the L bus are 24 bits 
wide, and the data paths are 44 bits wide, including 36 
bits for data and 8 bits for ECC. The L bus is capable of 
transferring one word per cycle at peak performance, 
approxhnately 20 MByte/sec. 

All L bus operations are synchronous with the system 
clock. The clock cycle is roughly 5 MHz, but the exact 
period of cycle may be tuned by the microcode. A field 
in the microcode allows different speed instructions for 
different purposes. For fast instructions, there is no need 
to wait the long clock cycle needed by slower instruc- 
tions. Main memory and cpu operations are synchro- 
nous with the L bus clock. When the cpu takes a trap, 
the clock cycle is stretched to allow a trap handler 
microinstruction to be fetched. 

As an example of L bus operation, a normal memory 
read cycle includes three phases: 

1. Request — The cpu or the FEP selects the memory 
card from which to read (address request). 

2. Active — The memory card access the data; the 
data is strobed to an output latch at the end of the cycle. 

3. Data— The memory card drives the data onto the 
bus; a new Request cycle can be started. 

In a normal write operation, two phases are carried 
out: 

1. Request— The cpu or the FEP selects the memory 
card to which to write. 

2. Active—The cpu or the FEP drives the data onto 
the bus. 

A modified memory cycle on the L bus is used for 
direct memory access operation by L bus devices. In a 
DMA output operation, as in all memory operations, 
the data from memory is routed to the ECC logic. How- 
ever, instead of passing on to the processor's instruction 
prefetch unit, the data is shipped to the DMA device 
(e.g., FEP, disk controller, network controller) that 
requested it. 

For block mode operation, the L bus uses pipelining 
techniques to overlap several bus requests. On block 
mode memory writes, an address may be requested 
while a separate data transfer takes place. On block 
mode memory reads, three address requests may be 
overlapped within one L bus cycle. 
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MEMORY AND CLOCK SIGNALS. (From <LMII^>MC.) 

The bus is used in three ways; accessing memory, accessing I/O device 

registers which look like memory, and accessing **MicroDevices" 

MicroDevices are distinguished because they are addressed by a 

separate 10-bit field which comes directly from the microcode, and do 

not follow the 3 cycle Request/Active/Data protocol of memories. One 

example of such a device is a DMA device such as the disk; the DMA 

task microcode commands the disk to put data onto the bus or take it 

off, while doing a memory cycle. We*ll call the three classes 

of responders "Memory, Memory Devices, and MicroDevices." 

All transactions on the L-bus are synchronous with the system clock. 

For example, memory responds to requests with a 2 or 3 cycle 

sequence, viz: 

On the first cycle (Request), the processor puts an address on LBUS 

ADDR, puts the type of cycle on LBUS WRITE, and asserts LBUS 

REQUEST. All the memory cards compare the high bits of the LBUS 

address with their slot number. The selected memory card drives the 

row address onto the RAM address Imes, and at the leading edge of 

LBUS CLOCK starts RAS. After a delay it muxes the column address 

onto the RAM address lines, and finally at the clock boundary CAS is 

enabled. 

The second (Active) cycle is used to access the RAM: on a read the 

RAM output is strobed into a latch at the end of the cycle; on a 

write, the bus has the write data and ECC bits and the RAM WE is 

driven by a gated Lbus Clock (late write operation). RAS and CAS 

are reset at the end of this cycle. 

During the third (Data) cycle, the latched read data is driven on 

the bus (during First Half), the RAM chips precharge during their 

RAS recovery time, and possibly a new Request cycle occurs. 

The bus clock is designed so that the memory card can start RAS with the 

leading edge and star CAS with the trailing edge and be guaranteed of 

meeting the RAM timing specs. No other use is intended for the leading 

edge of clock. It is suggested that MemoryDevices initiate response 

to requests at the trailing edge of clock. 

The clock seen by devices on the bus (LBUS CLOCK) is a version of the 

clock that drives the processor. Its frequency is roughly 5 Mhz but 

the exact period of each cycle may vary between 180-260 ns dependmg 

on the cycle length specified by the microcode. Although the 

processor controls the cycle length, LBUS CLOCK is unaffected by any 

clock inhibit conditions in the processor - operations on the bus 

proceed mdependently of the microcode, once they have been initiated. 

Memory data error-correction will also extend the clock for some 

period of time. 

An exception to this is when the processor takes a trap. In that case 

LBUS CLOCK is stretched - the extra time occurs in the second (or 

high) phase. While the main clock is held high, the clock and 

sequencer conspire to preform a second cycle internally that fetches 

the trap handler microinstruction. Because of this, two first-half 

clocks will happen for only one LBUS CLOCK. If the extended cycle is 

a Data cycle, the processor will latch the data seen during the first 

first-half. 

Note: The leadmg edge of FIRST HALF is > >not< < the same as the 

trailmg edge of LBUS CLOCK. First-half is primarily intended as a 

timing signal that controls enabling data from memories onto the bus. 

The only other nefarious use you are allowed is to clock something 

with the mid-cycle edge of FIRST HALF, and then you should be prepared 

to see two of them on some cycles. 

A central Memory Control manages the state of the bus and arbitrates 

between requests from the processor, IFU, and FEP. Both Memory and 

MemoryDevices are expected to conform to the same timing protocol. 

[document FEP/MC arbitration]. 

Any MemoryDevices Qike the TV) that are unable to respond m 3 cycles 

must assert LBUS WAIT during the Active cycle until they can respond. 

The memory control state will proceed on the first Active cycle where 

LBUS WAIT is not asserted. LBUS WAIT should not be present on any 

other cycle, and must be developed early enough to propogate the 

length of the bus, go through a xcvr, and gate the clock. DMA devices 

also watch LBUS WAIT, so they know which cycle is the one that they 

should read or write the data. 

Block mode operations. In some cases the processor issues a series of 

requests on back-to-back cycles. This is called **block mode". A new 

request can be started each cycle. When a block-mode operation in 

underway, the bus is segmented into a 3-stage pipeline, one stage for 

addressing, one stage for ram access, and one stage for data transfer 

(on reads). 

The addresses of block mode requests are always in increasing 

sequential order, although any pattern that avoids referencing 

addresses [n, n-l-4] in adjacent cycle would be OK. The existing 

memory card interleaves on bits 18,1,0, so an individual ram always 

see at least 4 cycles between requests for sequential locations. 

MemoryDevices also have to handle block mode requests, because the 

microcode will not in general want to distinguish references to MOS 
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memory from MemoryDevices. This means that the device must be 

prepared to accept a request during its "active" cycle. Request 

cycles are unconditional, there is no way for a device to reject or 

delay a request. The cycle following a request is the active cycle, 

which can be repeated (via LBUS WAIT) until the device is ready to 

accept data (on writes) or enter the data cycle (on reads). 

LBUS <43:0> - Bi-directional data bus, active high tri-state. 

LBUS <43:36> are the ECC bits. Driven by processor or FEP 

on write Active cycles. Driven by memories on read Data 

cycles. Also used to transfer data between processor and 

Devices. Also is used to carry the Obus signals from the data 

path card (E) to the other cards in the processor (I and C). 

LBUS ADDR<23:0> - Physical address. Tri-state driven from 

processor or FEP. A physical address of 24 bits is 

semi-consistent with allowing a maximum of 31 physical slots, 

each of which could hold 512K words of memory. 

LBUS CLOCK +/- - Differential ECL system clock. 

LBUS FIRST HALF +/- - differential ECL timing signal from memory control. 

Used during Data cycles to enable memory data onto the bus. 

The memory card drives dau onto the bus during the first half 

of the cycle, the memory control reads the bus data and does 

error correction. During the second half cycle, the corrected 

data is driven on the bus from the memory control. 

Memories must insure that data is driven out on the bus as 

soon as possible after the leading edge of FIRST HALF, because 

the memory control needs most of the first half to decode the 

ECC syndrome. 

LBUS REQUEST L - Request for Memory or MemoryDevices addressed by 

B\is.Address. Stable by leading edge of Bus.Clock enough 

time for address compare and 2 levels of logic. 

LBUS REQUEST L and LBUS WRITE L, along with the address, are 

asserted towards the end of the first cycle of a transaction. 

The data are transferred during the second or third cycle. 

The requests, write, and address lines are not valid during 

those cycles (indeed they may be used to start another transaction). 

LBUS WRITE L - from the processor or FEP. The write data will be 

driven onto the bus during the next cycle. Otherwise, the 

requested cycle is a read, and the memory will drive the bus 

during the 2nd succeeding cycle. 

LBUS WITH ECC - From Memories that don*t have ECC bits. Driven during 

Data cycle. 

LBUS WAIT L - From MemoryDevices. Asserted for as many cycles as 

necessary to hold memory control in Active cycle state. Must 

be valid early in the cycle. 

LBUS REFRESH L - All dynamic RAM memories perform a refresh. 

All rows of memory refresh at once. The memory array bypass 

capacitors hold enough charge to supply the RAMs for the 

refresh cycle, so the transient shouldn*t be seen by the power 

supply. The refresh timer and address counter is in the 

Memory Control, it has nothing to do with micro-tasking so 

that the memories will continue to get refreshed when the 

processor is being single stepped. 

LBUS ID REQUEST L - Requests that the selected board supply information 

about itself. The board selection is by matching 

LBUS ADDR <23:19> against the slot number (see below). 

LBUS <7:0> are driven with one of 32 bytes of data selected 

by LBUS ADDR <6:2>. The format of these data bytes is not 

yet specified, but generally includes the board type, board 

serial number, board revision level, and a checksum sensitive 

to failures of the data and address lines. 

Note that memory refreshing may take place, using LBUS ADDR 

< 17:10>, while a board ID is being read using the other 

address lines. The PROM data should be driven onto the bus 

for as long as ID REQUEST is asserted. (The memory card is 

slightly strange in that it "buffers" LBUS ADDR <6:2> through 

the same latch that it uses to hold the column address during 

normal memory cycles. This latch is open during LBUS CLOCK, 

so the memory board doesn't produce correct data until the 

second cycle after ID REQUEST and LBUS ADDR are present. The 

FEP compensates for this, and other boards shouldn't 

necessarily emulate the memory card. 

SLOT NUMBERING 

LBUS SLOT <4:0> - a slot number built into the blackplane. These pins 

are grounded in a different pattern at each slot; if the board plugged 

into that slot provides pullups it will see a unique slot number. 

This is matched against LBUS ADDR <23:19> for Memory, MemoryDevice, 

and IDRequest operations, and against LBUS DEV <9:5> for MicroDevice 

operations, to select the desire board, LBUS SLOT <4> is actually 

bussed across each card cage, and is grounded in the mam card cage 

and left floating in the extension cage. More discussion of this below. 

RESET SIGNALS 

LBUS RESET L - general reset line. This is brought low when power is turned 
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on, and whenever the FEP feels like asserting it. 

LBUS POWER RESET L - brought low when power is not valid. This line is used 

to protect disks and to perfonn initializations only needed when first 

powering on. When the machine is powered up, this line is grounded and 

remains grounded until the FEP validates the power and cooling and turns it 

off. This line is also grounded before turning off the power. 

MICRODEVICE SIGNALS 

LBUS DEV <9:0> - a device address from microdevice operations. Bits <9:5> 

select a board, by matching against the slot number. The special slot 

numbers 36 and 37 are used to select the FEP and MC boards, respectively. 

Bits <4:0> select a register or operation within the board. 

LBUS DEV READ L - commands the device to put data onto the Lbus data lines. 

LBUS DEV WRITE L - conmiands the device to take data from the Lbus data lines, 

at the LBUS CLOCK. Note that when LBUS DEV WRITE is used to inform the device 

of a DMA memory cycle being started, the Lbus data lines contain unrelated 

data perhaps associated with an unrelated memory read. LBUS DEV WRITE L should 

only be depended upon at the clock edge; it should not be used to gate the clock. 

If the microinstruction doing the microdevice write is NOPed by a trap or by 

a control-memory parity error (e.g. a microcode breakpoint), LBUS DEV WRITE L 

will be asserted for a period of time, past the leadmg edge of the clock, and 

will then be deasserted some time before the trailing (active) edge of the clock. 

LBUS DEV COND L - the selected device may ground this line (with an 

open-collector nand gate) to feed a skip condition to the microcode. 

Microdevice I/O is used for general communication with devices, for internal 

communication within the processor complex (including the FEP), and for 

control of DMA operations. 

For general communication with devices, the Lbus simply acts as an extension 

of the processor's internal bus. Data are transmitted within a single cycle 

and clocked at the trailing edge of the clock. 

Microdevice read and write to slot number 36 is used for communication with 

to FEP, the page tags, and the microsecond clock. Microdevice read and 

write to slot number 37 is used for communication with the MC and SQ 

boards. (It is used when reading and writing the NPC register in the SQ 

board in order to reserve the Lbus and connect it to the datapath; the 

control signals to the SQ board are transmitted separately.) 

DMA works as follows. The device reguests a task wakeup when it wants to 

transfer a word to or from memory. The microcode task wakes up for 2 

cycles. The first cycle puts the address on the Lbus address Imes, makes 

a read or write request to memory, and also increments the address. The 

second cycle decrements the word count, to decide when the transfer is 

done. The microcode asserts DISMISS during the first cycle (the task 

switch occurs after the second cycle.) The device is mformed of the DMA 

operation by the microcode through the use of a microdevice write during 

the first cycle. This microdevice write does not transfer any data to the 

device, but simply tells it that a DMA operation is being performed, and 

clears its wakeup request flag. (The wakeup request is removed from the 

bus immediately, and the flag is cleared at the clock edge.) For a read 

from device into memory, the device puts the data on the bus during the 

active cycle (one cycle after the microdevice write) and it is written into 

memory. For a write, the device takes data from the bus two cycles after 

the microdevice write. 

Some devices look like memory, rather than using microdevice I/O. The 

criterion for which to use is generally whether the device is operated 

by special microcodes, and the convenience and need for speed of that microcode. 

Devices that look like memory can be accessed directly by Lisp code. 

SPY SIGNALS 

SPY <7:0> - an 8-bit, bidirectional, rather slow bus used for diagnostic 

purposes. Allows the FEP to read and write various cpu state while the 

machine is running. 

SPY ADDR <5:0> - addresses the diagnostic register to be read or written 

SPY READ L - gates data from the selected register onto the spy bus. 

SPY WRITE L - clocks data from the spy bus into the selected register, on 

the trailing edge. 

SPY DMA SIGNALS 

When the spy bus isn't being used for diagnostics, the FEP uses it as a 

special side-door path to certain DMA devices. Normally the FEP uses it 

to receive a copy of all incoming network packets; it can also set it up 

to transmit to the network and to read from the disk (possibly also to 

write the disk; this is unclear and not yet determined). Details are 

in <LMHARD>DMA.DESIGN; that part of that file is said to be up to date. 

SPY <7:0> - 8 bits of data to or from DMA device. These lines are 

continuously driven during DMA operations; the FEP's DMA buffer does 

not latch them. 

SPY DMA ENB L - asserted if DMA operations are permitted to take place; 

deasserted if the spy is being used for diagnostic purposes. 

SPY DMA SYNC | - a clock, asseted by the device. On the rising edge of 

this a byte is transferred and the address is incremented. The device 

must take the data (for write) or supply the new data (for read) on or 

before the leading edge of this. This is the same wire as SPY ADDR 0. 

SPY DMA BUSY L - asserted if the DMA operation has not yet completed. 

This can be asserted by the device or the FEP or both, dependmg on who 

determines the length of the transfer. For example, for network input 
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this comes from the device, while for network output and disk mput 
it comes from the FEP (the disk doesn't know it's own block size). 
This is the same wire as SPY ADDR 1. 
Timing Requirements. 

LBUS RESET and LBUS POWER RESET are asynchronous. All other side-effects 

should take place at the trailing edge of the clock. LBUS REQUEST and 

the address Imes are stable before the leading edge of the clock. LBUS WRITE 

however is only valid at the trailing edge of the clock; it can change as 

the result of a trap. Consequently it is illegal for memory reads to have 

stde-effects^ as memory reads not requested by the prograni can occur. 

In a microdevice write, the address lines (LBUS DEV 0-9) are stable throughout 

the cycle, however the data (LBUS 0-35) and LBUS WRITE itself arc only valid 

at the trailing edge of the clock. The data lines are only driven during 

SECOND HALF. 

In a microdevice read, the address lines (LBUS DEV 0-9) are stable 

throughout the cycle, however LBUS READ itself is only valid at the 

trailing edge of the clock; side-effects are permitted but may only happen 

at the clock. The data (LBUS 0-35 or in some devices LBUS 0-31) should be 

driven throughout the cycle. 

TASK 8-15 REQ and TASK 4 REQ are asynchronous and may be driven at any time. 

Once a task is requested, it should stay requested until explicitly dismissed 

or until LBUS RESET. When a task is dismissed, the task request must be 

deasserted during the cycle that is dismissing, so that a new task of 

presumably lower priority can be scheduled. The task request flip flop 

however must not be cleared until the trailmg edge of the clock, the 

time when all side-effects occur. During the cycle after a dismiss the 

task request will not be looked at by the processor, however the device 

should deassert its request as quickly as it can (a glitch is expected 

at the beginning of the cycle). 

Data driven onto the Lbus data Imes (LBUS 0-43) must be synchronized to 

the processor clock; failure to observe this rule can cause every sort of 

internal parity error in the processor as well as memory ECC errors. When 

reading from memory, the data must be stable on the bus as early as 

possible, to allow time for the ECC-error decision before the end of FIRST 

HALF. Memory read data are driven onto the bus during FIRST HALF, and then 

latched by the processor during SECOND HALF. This latch is followed by a 

second one, that is opened during the middle of FIRST HALF to pick up the 

raw data, and again during the middle of SECOND HALF to pick up the 

ECC-correctcd data (if any). ("Middle" is controlled by PROC WP). Even 

devices that deassert LBUS WITH ECC must provide the data early enough to 

avoid synchronizer failure in either of these latches. 

When reading from a microdevice, there is more timing leeway since the 

microcode knows the specific device it is reading from and can use 

a slow-first-half cycle. Also there is no ECC computation. The microdevice 

drives the data lines during the first half and the processor 

effectively clocks them at the traUing edge of FIRST HALF (actually there 

is one latch open during FIRST HALF followed by a second latch open 

during SECOND HALF; this is done for hardware minimization reasons). 

The device data must be stable early enough to avoid synchronizer 

failure m these latches. The microcode will use a slow-second-half 

cycle if necessary, since it does not see the data until SECOND HALF. 

Lbus data lines not driven by a microdevice will be brought to 1 by 

the terminator, but not quicldy enough to avoid problems. Thus all 

microdevice reads must drive at least LBUS 0-33. 

Note that when doing a memory read, the data are driven two clocks 

after the request (skipping LBUS WAIT cycles); the bus-driver enable 

should come from a clocked register. When doing a microdevice read. 

the data are driven by LBUS DEV READ gated by matchmg of LBUS DEV ADDR 

9-5. LBUS DEV READ takes some tune after the beginning of the cycle 

to become stable, and the device should introduce as little additional 

delay as it can. The device should only drive the bus during FIRST HALF, 

so that it turns off in plenty of time before the next cycle. 

When writing into memory from a DMA device, the data, includmg the ECC 

code added by the memory control, must be stable at the memory chips 

before the leading edge of the clock (which is when WRITE is asserted 

to the RAMs). 

When a cycle is extended because of a trap, so that FIRST HALF happens twice, 

the latch through which the processor receives Lbus data is only opened 

during the first FIRST HALF. When a cycle is repeated because of LBUS WAIT, 

memory-read data arc only received from the bus during the first mstance 

of the cycle. (This only happens when a block read is done from a device 

that uses LBUS WAIT, since only in a block read can an active cycle and 

a data cycle coincide, and LBUS WAIT is associated with active cycles.) 

Microdevice-write and memory-write data are driven during throughout an 

extended or repeated cycle (microdevice-write data are only driven during 

SECOND HALF). 

The leadmg edge of FIRST HALF does not precede the traUing edge of 

the clock. It is not a good idea to depend on this. The trailmg 

edge of FIRST-HALF preceeds the leading edge of the clock. 

LBUS WITH ECC is driven with the same timing requirements as the data 

lines. 

LBUS DEV COND must be sUble before the trailing edge of the clock. 
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SPY ADDR 5-0 are stable whenever SPY READ or SPY WRITE is asserted. 
The SPY data lines should be clocked by the trailing edge of SPY WRITE, 
and should be driven whenever SPY READ is asserted. If a bidirectional 
transceiver is used to bring the SPY bus onto a board, its direction 
should be controlled by SPY READ, so that it will not glitch at the 
trailing edge of SPY WRITE; the FEP latches the SPY lines before it 
deasserts SPY READ. The FEP allows a long time [?? ns] for a spy 
read or write, so slow logic may be employed on this bus. 



LBUS ADDR 0-11 


AAl-12 


DP SQ- MC* AU- FEP* BUS 


LBUS ADDR 12-23 


AA13-24 


MC* AU- FEP* BUS 


U TYPE MAP SKI, 0-5 


AA13-18 


DPSQ* 


SPY READ DP ID L 


AA19 


DPSQ* 


U XYBUS SEL 


AA20 


DPSQ* 


U STKP COUNT 


AA21 


DPSQ* 


U OBUS COR 0-2 


AA22-24 


DPSQ* 


U OBUS HTYPE 0-2 


AA25-27 


DPSQ* 


LBUS ID REQUEST L 


AA25 


MC- AU- FEP* BUS 


LBUS BLOCK REQUEST L 


AA26 


MC* AU- FEP- BUS- 


LBUS DEV READ L 


AA27 


MC* AU- FEP BUS 


U OBUS LTYPE SEL 


AA28 


DPSQ* 


LBUS DEV WRITE L 


AA28 


MC* AU- FEP BUS 


LBUS DEV COND L 


AA29 


DP- SQ MC- AU- FEP- BUS* 


FEP CONTINUITY 


AA30 


DP SQ MC AU FEP* 



Asserted by the FEP and read back on the other continuity lines 

to detect the presence of processor boards (and in the correct slots). 

MC CONTINUITY AA31 DP- SQ- MC* AU- FEP 

Jumpered to FEP CONTINUITY on the MC card. 

SQ CONTINUITY AA32 DP- SQ* MC- AU- FEP 

Jumpered to FEP CONTINUITY on the SQ card. 

LBUS 0-29 ACl-30 DP* SQ MC* AU FEP* BUS* 

DP CONTINUITY AC31 DP* SQ- MC- AU- FEP 

Jumpered to FEP CONTINUITY on the DP card. 

AU CONTINUITY AC32 DP- SQ- MC- AU* FEP 

Jumpered to I^P CONTINUITY on the AU card, 

SPY 0-7 BAl-8 DP- SQ* MC* FEP* BUS* 

SPY ADDR 0-5 BA9-14 DP- SQ MC AU FEP* BUS 

SPY ADDR 0-1 also used for FEP-DMA 

SPY READ L BA15 DP- SQ MC AU FEP* BUS 

SPY WRITE L BA16 DP- SQ MC AU FEP* BUS 

SPY DMA ENB L BA17 FEP* BUS 

(spare) BA17 DP- SQ- MC- AU- 

TASK 4 REQ L BA18 DP- SQ MC- AU- FEP- BUS* 

Low-priority task wakeup 

LBUS DEV 0-9 BA19-28 DP SQ* MC AU- FEP BUS 

U AMWA 0-9 

Note that these lines have two names, since they serve as both the 

Lbus microdevice address and some datapath control signals. The same 

wires are bussed all the way through both the processor and the Lbus. 

LBUS FIRST HALF +,- BA29,BC29 FEP* BUS 

Terminate with 68 ohms to -2 V at end of BUS. 

(spare) BA29,BC29 DP- SQ- MC- AU- 

TASK 8-9 REQ L BA30,BC30 DP- SQ MC- AU- BUS* 

(See below; listed here since they fall here in pm order) 

(spare) BA31 DP- SQ- 

-COND BC31 DP* SQ* 

EXTERNAL REQUEST L BA31 MC- *** BUS* 

EXTERNAL GRANT L BC31 MC* *** BUS- 

Traces between SQ and MC should be cut. These will have 

to be jumpered around the AU and FE slots. 

LBUS CLOCK +,- BA30,BC30 FEP* 

BA32,BC32 BUS 

Terminate with 68 ohms to —2 V at end of BUS. 
Note that these signals change pin number at the FEP. 
PROC CLOCK -F,- BA32,BC32 DP SQ MC AU 

BA31,BC31 FEP* 

(Separately-driven duplicate of LBUS CLOCK. 
Terminate with 68 ohms to —2 V at DP end. 
Note that these signals change pin number at the FEP. 

LBUS 30-35 BCl-6 DP* SQ MC* AU FEP* BUS* 

LBUS 36-43 BC7-14 MC* AU FEP* BUS* 

DP TRANSPORT TRAP L BC7 DP* SQ 

Asserted if a trap is required for garbage-collector processing 
of the data being read from memory (a function of the data type 
and the high-order address field). 

DP TYPE TRAP BC8 DP* SQ 

Asserted if the type map calls for a trap (bad data type or 
invisible pointer). 

DP TRAP PARAM 0-3 BC9-12 DP* SQ 

Trap parameter (dispatch code for arithmetic trap, trap number 
for type trap). 

DP SLOW JUMP L BC13 DP* SQ 

Asserted if a non-NOPing trap is required (used by the stack 
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garbage collector that doesn't exist yet). 

DP MISC TRAP BC14 DP* SQ 

lOR of trap conditions other than the above. 

LBUS WITH ECC BC15 MC AU- FEP BUS* 

AMEM PAR ERR L BC15 DP* SQ 

Parity error in A-memory; stops machine 

(spare) BC16 DP- SQ- MC- AU- FEP- BUS- 

Spare Lbus line 

LBUS POWER RESET L BC17 DP SQ MC AU FEP* BUS 

Terminate somehow. May need to be brought out to power supply? 

(May go to front panel also, but FEP will provide that connection.) 

TASK 8-15 REQ L BA30,BC30,BC 18-23 DP- SQ MC- AU- FEP- BUS* 

TASK 8-9 REQ L are not connected to the FEP, 

LBUS REQUEST L BC24 MC* AU- FEP* BUS 

TYPE PAR ERR L BC24 DP* SQ 

Parity error in type map 

LBUS WRITE L BC25 MC* AU- FEP* BUS 

GC MAP PAR ERR L BC25 DP* SQ 

Parity error in garbage-collector address-space-quantum map 

LBUS REFRESH L BC26 MC- AU- FEP* BUS 

BMEM PAR ERR L BC26 DP* SQ 

Parity error in B-mcmory; stops machine 

LBUS WAIT L BC27 DP SQ- MC AU- FEP BUS* 

LBUS RESET L BC28 DP SQ MC AU FEP* BUS 

PRCX;WP+,- CAUCCl DPSQMCAUFEP* 

Write-pulse for internal static RAMs; occurs twice per cycle. 

Terminate with 68 ohms to -2 V at DP end. 

PROC FIRST HALF +.- CA2,CC2 DP SQ MC AU FEP* 

Separately-driven duplicate of LBUS FIRST HALF. 

Terminate with 68 ohms to -2 V at DP end. 

CLK EXTEND CYCLE CAS DP* SQ- MC* AU- FEP 

A wircd-OR ECL signal, asserted when extra time is needed for a trap. 

Terminate with 100 ohms to —2 V at DP end and on FEP. 

CLK CS PRESET L CA4 DP SQ- MC- AU- FEP* 

Forces chip-select for A,B memories on at the beginning of the cycle, 

until there has been enough time for the pass-around decision. 

(Saves a few nanoseconds). 

SQ NEXT INST L CAS DP SQ* MC AU- FEP- 

Assertcd if this is the last microinstruction for this 

macroinstruction. 

UAMRAO-5 CA6-11 DP SQ* 

FEP LBUS RQ L CA6 MC AU- FEP* 

Asserted if FEP wants the bus or is using it (active cycle), 

REFRESH RQ L CA7 MC AU- FEP* 

Asserted if time for a memory refresh, or refresh active cycle. 

MC ECC DELAY CA8 MC* AU- FEP 

Extends the clock during the second half in order to provide 

time for single-bit error correction. 

This is an ECL signal. 

DOUBLE ECC ERROR L CA9 MC* AU- FEP 

True if there is an uncorrectable error in the data for this 

memory read. 

(unknown) CA 10- U MC AU- FEP 

U AMRA 6-U CAI2-17 DP SQ* MC AU(-?) 

U AMRA SEL 0-1 CA18-19 DP SQ* MC AU(-?) 

U AMWA 10-11 CA20-21 DP SQ* MC AU(-?) 

UAMWASELO-1 CA22-23 DP SQ* MC AU(-?) 

U MAGIC 0-3 CA24-27 DP SQ* MC AU 

U SPEC 0-4 CA28-32 DP SQ* MC AU 

CLK WO ENB L CC3 DP SQ- MC- AU- FEP* 

Another timing signal for A,B memory. 

DP SET GC TAG L CC4 DP* SQ- MC- AU- FEP 

Registered output from the GC map indicating that the 

Abus datum is a pointer to a temporary space. This sets 

a GC page tag bit if main memory is being written. 

NOP L CCS DP SQ* MC AU FEP- 

Asserted if the current microinstruction should not do 

anything, because the processor is stopped, stalled, or 

trapping (valid late, should not be used to gate the clock). 

U SPEED 0-1 CC6-7 DP- SQ* MC- AU- FEP 

CLK EXTRA INNINGS CC8 DP- SQ MC- AU- FEP* 

Asserted during the second cycle of a trap. 

TASK 3 REQ CC9 DP- SQ MC- AU- FEP* 

Task wakeup from the FEP 

MC PROC NORMAL GRANT L CCIO DP SQ- MC* AU- FEP 

Asserted if the LBUS ADDR lines contain an address derived 

by mapping the VMA to a physical address. This signal enables 

the DP card to capture the mapped address for possible later 

use in addressing A-memory. Also used by the page tag memory. 

PAGE TAG PAR ERR L CCl 1 DP- SQ MC- AU- FEP* 

Parity error in page tag memory; stops machine. 

SPARE ERROR L CCl 2 DP- SQ MC- AU- 
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Grounding this halts the machine after completing the current 

microinstruction; 

(spare) CC13-15 DP- SQ- MC- AU- 

Bus these across processor (except FEP) and maybe we'll 

find a need for them. 

INST 0-7 CC16-23 DP MC* 

Low 8 bits of the current macroinstniction. 

Note: these lines are wired around the SQ slot. 

U AU OP 0-7 CC16-23 SQ* AU 

Microcode control for the AU. 

[This assumes 8 more bits of control memory are wedged in.] 

Note: these lines are wired around the MC slot. 

AU STOP L CC24 SQ AU* 

Any error on the AU that needs to stop the machine. 

Note: this line is wired around the MC slot. 

(spare) CC25-28 SQ- AU- 

Connect these between the SQ and AU for possible future use 

Note: these lines are wired around the MC slot. 

SEQUENCE BREAK CC24 DP* MC 

Macrocode interrupt request. 

Note: this line is wired around the SQ slot. 

MC COND CC25 DP MC* 

A microcode skip condition. 

Note: this line is wired around the SQ slot, 

MC OBUS TO LBUS L CC26 DP MC* 

Enables the datapath output to drive the Lbus 

Note: this line is wired around the SQ slot, 

MC OBUS REG TO LBUS L CC27 DP MC* 

Enables the datapath result from the previous microinstruction 

to drive the Lbus (used when writing main memory) 

Note: this line is wired around the SQ slot, 

MC ADDR IN AMEM L CC28 DP MC* 

Indicates that the VMA maps to an A-memory address 

Note: this line is wired around the SQ slot. 

MC ABUS 32-35 CC29-32 DP* SQ- MC* AU* 

Data bus between DP, MC, and AU. 

MC ABUS 0-31 DCl-32 DP* 

DAl-32 MC* AU* 

Bidirectional data bus between DP, MC, and AU. 
Note: this is wired around the SQ slot. 

Note: this is on the "C" column at the DP, but the "A" column 
elsewhere. 
U BMRA 0-7 
U BMWA 0-3 
U BMEM FROM XBUS 
U COND FUNC 0-1 
U COND SEL 0-4 
U BYTE F 0-1 
U ALU 0-3 
DISPATCH 0-3 

Contents of field being dispatched on 
(spare) 
(spare) 

CUR TASK 0-3 

Task in which the current microinstruction is executing 
TASK SWITCH L DC9 SQ* MC 

Asserted if the next microinstruction will be from a different task 
WANT NEXT INST DCIO SQ* MC 

Asserted if the address supplied by the IFU in the previous cycle 
is actually being used as the next microinstruction address. 
Stalls the processor if the address was not valid after all. 
MCWAIT DCll SQMC* 

Asserted if the processor must stall and wait for the Lbus 
MC MAP MISS L DC12 SQ MC* 

Asserted if a map-miss trap should be taken 

MC TRAP PARAM 0-1 DC13,14 SQ MC* 

Modifiers for trap address 

MC TASK INHIBIT L DC15 SQ MC* 

Inhibits a task switch after the next instruction. 

MC STOP L DC16 SQ MC* 

Any parity error on MC board; stops processor. 

IFU DISP 2-13 DC18-28 SQMC* 

Control-memory address of the first microinstruction to execute 
the next macroinstniction 

(spare) DC29-30 SQ- MC- 

U MEM 2-0 DC17,DC31-32 SQ* MC 

Memory-control control field 

Bit 2 is not next to the other bits for historical reasons 
Pins DCl-32 on the AU slot are left unconnected for possible cabling 
to a second board or other expansion. 
Pins CAll-32, CC12-32, DAl-32, DCl-32 on the FEP slot are left unconnected 



DAl-8 


DPSQ* 


DAS-12 


DPSQ* 


DA13 


DPSQ* 


DA14-15 


DPSQ* 


DA16-20 


DPSQ* 


DA21-22 


DPSQ* 


DA23-26 


DPSQ* 


DA27-30 


DP*SQ 


DA31-32 


DP- SQ- 


DCl-4 


SQ- MC- 


DC5-8 


SQ*MC 
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for paddleboard use. 



Data motion instructions — The instructions move 
data without changing it. Examples include PUSH, 

A main goal of the system architecture is to execute POP, MOVEM, and RETURN, 
one simple macroinstruction per clock tick. The instruc- Housekeeping instructions — These are used in mes- 

tion fetch unit (IFU) supports this goal by attempting to . sage-passing, function called, and stack manipulation, 
prefetch macroinstructions and perform micromstruc- Examples include POP-N, FIX-TOS, BIND, UN- 
tion dispatchuxg in parallel with the execution of previ- BIND, SAVE-BINDING-STACK-LEVEL, 

ous instructions. CATCH-OPEN, and CATCH-CLOSE. 

The prefetch (PF) part of the IFU fills a 1 Kword Function calling mstructions—These use a non- 

mstruction cache, which holds the 36-bit instruction 15 inverted calling sequence; the arguments are already on 
words. Approximately 2000 17-bit instructions can be the stack. Examples include CALL, FUNCALL, FUN- 
held in the instruction cache. The mstructions have a CALL-VAR, LEXPR-FUNCALL, and SEND, 
data type (integer). The IFU feeds the cache takes the Function entry instructions— These are used within 

instructions, decodes them, and produces a microcode functions that take more than four arguments or have a 
address. There is a table which translates a macroin- rest argument, and hence do not have their arguments 
struction onto an address of the first microinstriction. set up by microcode. Examples include TAKE-N- 

At the end of the clock tick the processor decides ARGS, TAKE-N-ARGS-REST, TAKE-N-OPTION- 
whether it needs a new instruction or it should continue AL-ARGS, TAKE-N-OPTIONAL-ARGS-REST. 
executing microcode. 25 Function return instructions — These return values 

The system instruction set corresponds very closely from a function. The main opcode 9 is RETURN, with 
to Zetalisp. Although one never programs directly in some variations. 

the instruction set one will encounter the instruction set Multiple value receiving instructions—These take 

when using the Inspector or the Window Error Han- some number of values off the stack. Example: TAKE- 
dler. The instructions are 17 bits long. Seven instruction ^^ VALUES, 
formats are used: Quick fimction call and return mstructions — These 

1. Unsigned-immediate operand— This format is used are fast function calls. Example: POPJ. 

for program-counter-relative branches, immediate fix- Branch instructions — Branches change the flow of 

num arithmetic, and specialized instructions such as 35 program control. Branches may be relative to the pro- 
adjusting the height of the stack. gram counter or to the stack. 

2. Signed-immediate operand — The operand is an Predicates — These include standard tests such as EQ, 
8-bit two's complement quantity. It is used in a similar EQL, NOT, PLUSP, MINUSP, LESSP, GREA- 
manner as the unsigned-immediate format. TERP, ATOM, FIXP, FLOATP, NUMBERP, and 

3. PC-relative operand— This is sunilar to signed- "^ SYMBOLP. 

inmiediate, with the offset relative to the program Arithmetic instructions— These perform the standard 

counter. arithmetic, logical, and bit-manipulation operations. 

4. No-operand— If there are any operands, they are Examples include ADD, SUBTRACT, MULTIPLY, 
not specified, since it is assumed they are on the top of 45 TRUNC2 (this does both division and remainer), LO- 
the stack. Also used by many basic Zetalisp instructions. GAND, LOGIOR, LOGXOR, LDB, DPB, LSH, 

5. Link operand— This specifies a reference to a link- ROT, and ASH. 

age area in a function header. List instructions— Many Zetalisp list-manipulation 

6. @Link operand— This specifies an indirect refer- instructions are microcode directly into the system. 
ence to a stack frame area associated with a function. 50 Examples are CAR, CDR, RPLACA, and RPLACD. 

7. Local operand— The operands are on the stack or Symbol instructions— These mstructions manipulate 
within a ftmction frame. This format is used for many symbols and their property lists. Examples include 
basis Zetalisp instructions. SET, SYMEVAL, FSET, FSYMEVAL, FBOUNDP, 

Many instructions address a source of data on which 55 BOUNDP, GET-PNAME, VALUE-CELL-LOCA- 
they operate. If they need more than one argument, the TION, FUNCTION-CELL-LOCATION, PROPER- 
other arguments come from the stack. Examples include TY-CELL-LOCATION, PACAKGE-CELL-LOCA- 
PUSH (push source onto the stack), ADD (add source TION. 

and the top of stack), and CAR (take the car of the Array instructions— This category defines and 

source and push it onto the stack). These instructions 60 quickly manipulates arrays. Examples include AR-1, 
exist in several formats. AS-1, SETUP- ID- ARRAY, FAST-AREF, ARRAY- 

There is no separate destination field m the system LEADER, STORE-ARRAY-LEADER are used to 
instructions. All instructions have a version which access structure fields. 

pushes onto the stack. Additional opcodes are used to , Miscellaneous instructions — These include pseudo 
specify other destinations. data movement instructions, type-checking instruc- 

The following categories of instructions are defined tions, and error recovery mstructions not used in nor- 
for the system: mal compiled code. 
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The system instruction execution engine works using speeds up to 1 Mbaud. All four lines are terminated 
a combination of hardware and microcode. The engine using standard 25-pin D connectors, 
includes hardware for the following functions: Real-time interrupts from the MULTIBUS are pro- 
Address computation ^ ^ess^^ ^^ ^^e FEP, After receiving an interrupt, the 
Type-checkmg ,^. ^ ,, FEP traps to the appropriate interrupt handler. This 
Rotation, masking, and merffme of bit fields uji -^'^ . .. 
A •*!, I J 1 • 1 r :• handler wntes mto a system commumcation area of the 
Antnmetic and logical functions t7t?ti» • j i . . 

Multiplication and division ^^^ ' ^^,°'!^^'^' ^^ '^'^ ''^^' ^ ^^'"'^^P' '° '^" 

Result-type insertion ,. '^'^^"^ ^^^^ ^^ ^^^^^^ ^^^ '^^^^ ^^^ °^^s^^S« 1^^* 

To give an example of the instruction execution en- ^''' '^ !^ ^^^ '^'^^^ communication area and takes ap- 

gine, a 32-bit add instruction goes through the foUowmg P^opnate action. 

sequence of events. '^^ paddle cards of FIGS. 168-176 provide the re- 
Fetch the operands (usually from the stack); error minder of the external bus interface circuitry. Table 5 
correction logic (ECC) checks the mtegrity of the data; 15 below mdicates the signals to and from the paddle 
ECC does not add to the execution time if the data is boards for a storage module drive disk controller and 
valid. for a priam device. 
Check the data type fields. Interrupt processing is sped up by the use of multiple 
Assume the operands are integers and perform the microcontexts stored in the system processor. This 
32-bit add in parallel with the data type checking (If the makes mterrupt servicing faster, smce there is no need 
operands were not integers, trap to the microcode to to save a full microcontext before branching to the 
fetch the operands and perform a different type of add). interrupt handler. 
Check for overflow (if present, trap to microcode). The FEP also has the ability to achieve processor 
Tag the result with the proper data type. 25 mediated DMA transfers. 

Push the result onto the stack. DMA operations from the system to the FEP may be 

There is no overhead associated with data type .^.^ out at a rate of 2 MByte per second, 

checkmg smce it goes on m parallel with the mstruction, j/f^ ^^„^^^ t^xvta ; + jt /* ^.t^t^ u xt 

within the same cycle. J^^ ^7^!f ^^ "^^^'^^^^ (*^ ^^^ ^^^^^^ ^^^ ^^ 

Rather than having the ECC distributed on aU of the 30 Microcode Tasks) 

boards of the system as shown in FIG. 1, a single cen- -^„ r-?i ^^!^^' • i 

trahzed ECC is located on the memory control board. ^^ ^"^^^ ^""^^^ "^'^^ ^^*^' arranged so that carry out 

All data transfers into and out of the memory and on the ^^ ^^^^r address counter happens at right time for stop 

Lbus pass through the smgle centrahzed ECC. The ^^^^ ^° device. FEP resets address counter to point to 

transfers between peripherals and the FEP during a ^^^^ ^^^^ ^^ ^^^- ^^^ ^^^^ ^^^^^^ ^o*^^ to enable 

micro DMA also pass through the centrallized ECC on ^^^^^ data to drive the bus (SPY 7:0), sets device to tell 

the way to the main memory. it what operation, the face that it is talking to the FEP, 

FRONT END PROCESSOR ^ DMrSTOC '' '° '^""'^ ^^ ^"^ '°"''°^ "^'^ ^'''^ 

During normal operation, the FEP controls the low Device takes a word of data off of the bus and gener- 

and medium-speed input/output (J/O) devices, logs ates a pulse on SPY DMA SYNC. The trailing edge of 

errors, and initiates recovery procedures if necessary. this pulse increments the address counter as well as 

The use of the FEP drastically reduces the real-time clocking the bus into the device's shift register. A carry 

response requirements imposed directly on the system 45 comes out of the address counter during this pulse if this 

T'TJi^teHTtt' . "" 'T'^^^ ^"''^°"''^ """ i« *« l^t word (or near the last, depending on device); 

■^e^SelVlfiTirf H • . . this carry clears SPY DMA BUSY which tells the de- 

Ine rront end process also feeds a generic bus net- 
work which is interfaced through the FEP to the Lbus ,^ "^^^tu ^ c?.v r^xji a t^tto^ i ^ ^^r. • . 
and which, by means of other interfaces are able to '" ^^f ^ ^^^ ^^^ ^^^^ ^^^^^ '^^ ^^^ '' ''''''' 
convert Lbus data and control signals to the particular ^P^^"; 
signals of an external bus to which peripherals of that Device to FEP: 

external bus type may be connected. An example of an ^°^ ^^^* ^^^^ ^^^^^ ^ ^*°P ^^^nal, FEP arranges 

external bus of this type is the multibus. The Lbus data 55 ^^^^^^s counter so carry out will generate a stop signal. 

and control signals are converted to a generic bus for- Network generates its own stop signal based on end-of- 

mat by the circuitry of FIGS. 151-2 and 157-8 indepen- packet incoming. FEP resets address counter to point 

dent of the particular external bus to be connected to ^^^ "^^^^ before where first word of data should be 

and thereafter convert the generic bus format of data stored. FEP sets buffer mode to not drive the bus and to 

and control signals to that of the external bus. ^ ^o writes into buffer memory, sets device to tell it what 

Four serial lines are connected to the FEP. Two are operation, the fact that it is talking to the FEP, to enable 

high-speed and two are low-speed. Each one may be it to drive the bus from a register, and to enable it to 

used either synchronously or asynchronously. One drive the bus control signals SPY DMA SYNC and 

high-speed Une is always dedicated to a system console, gg SPY DMA BUSY (if it is the net). 

One low speed line must be dedicated to a modem. The When device has a word of data, it generates a pulse 

band rate of the low-speed Imes is programmable, up to on SPY DMA SYNC. Trailmg edge of this pulse clocks 

19.2 Kbaud. The available high-speed Ime is capable of the data into a register in the device, which is driving 
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SPY 7:0, and increments the address counter, which 
reflects back SPY DMA BUSY (if device is the disk). 
The buffer control logic waits for address and data 
setup time then generates an appropriate write pulse to ^ 
the memory. 

When SPY DMA BUSY clears the FEP is inter- 
rupted. 
To summarize device FET interface lines: 
SPY 7:0 10 

Bidirectional data bus. This is the same bus used for 
diagnostics. 
SPY DMA ENB L 

Asserted if the spy bus may be used for DMA. The 15 
FEP deasserts this when doing diagnostic reads and 
writes, to make sure that no DMA device drives the spy 
bus. 

SPY DMA SYNC 

20 
Driven by selected device, trailing (rising) edge m- 

crements address counter and starts write timing chain. 

This is open-collector. 

SPY DMA BUSY L 

An open-collector signal which is asserted until the 25 
transfer is over. This is driven by the device or the FEP 
depending on who decides the length of the transfer. 
(Probably the FEP drives it from a flip flop optionally 
set by the program, and cleared by the counter over- -« 
flow.) The FEP can enable itself to be interrupted when 
SPY DMA BUSY is non-asserted. 

An I/O or generic bus is used to set up the device's 
control registers to perform the transfer and to drive or 
receive the above signals. Note that all of the tristate ^5 
enables are set up before the transfer begins and remain 
constant during the entire transfer. 

Device to microtask: 

The devices control resistors are first set up using the 4Q 
I/O bus and the state of the microtask is initialized (both 
its PC and its variables, typically address and word 
count). A task number is stored into a control register in 
the device. 

When the device has a word of data, it transfers it to ^^ 
a buffer register and sets WAKEUP. This is the same 
timing as FEP DMA NEXT: WAKEUP may be set on 
either edge since the processor will not service the 
request Instantaneously. If WAKEUP is already set, it 50 
sets OVERRUN, which will be tested after the transfer 
is over. 

The processor decides to run the task (see below). 
During the first cycle, the task microcode specifies 
DISMISS: the device sees this, gated by the current 
task equals its assigned task number, and clears 
WAKEUP at the end of the cycle. DISMISS also 
causes the processor to choose a new task internally. 
The microcode also generates a physical address. The 60 
device also sees the microcode function DMA-WRITE, 
gates by current task equals device's task, and drives the 
huffier register onto the bus. The processor drives the 
ECC-syndrome part of the bus and sends a write com- 
mand to the memory. 

During the second cycle, the processor counts down 
the word count, and does a conditional skip which 



55 



65 



affects at what PC the task wakes up next time, depend- 
ing on whether the buffer has run out. 

During the cycle two cycles before the first task 
cycle, the device drives its status onto 3 or 4 special bus 
Imes, which the microtask may have enables to dispatch 
on. This is used for such things as stopping on disk 
errors and stopping at the end of a network packet. 

Microtask to device: 

The device's control registers are first set up using the 
I/O bus, and the state of the microtask is initialized 
(both its PC and its variables, typically address and 
word count). A task number is stored into a control 
register in the device. WAKEUP is forced on so that 
the first word of data will be fetched. 

When the device wants a word of data, it takes it 
from a buffer register and sets WAKEUP so that the 
microtask will refill the buffer register. At the same time 
it sets BUFFER EMPTY, and if it is already set, sets 
OVERRUN. 

During the fu:st cycle of the task, the microcode 
spcifies DISMISS, which clears wakeup. It also gener- 
ates an address and specifies DMA-READ. In the sec- 
ond cycle the task decrements the word count. In the 
third cycle (task not running), the ECC-corrected data 
is on the bus; at the iend of this cycle it is clocked into 
the buffer register and BUFFER EMPTY is cleared. 
DMA-READ anded with current task-device task is 
delayed through two flip-flops then used to enable this 
clocking of the holding register. 

Task selection hardware (in device and processor): 

Device has a task-nimiber register and a WAKEUP 
flip/flop, which is set by the device and cleared by the 
DISMISS signal from the processor when the current 
task equals the device's task. This can be an R/S flip 
flop or a J/K with either the set or the clear edge-trig- 
gered depending on what the device wants; the proces- 
sor doesn't care. In the device to microtask case above, 
WAKEUP was being used for the overrun computa- 
tion, and therefore the clearing should be edge-trig- 
gered. 

WAKEUP enables an open-collector 3-8 decoder 
which decodes the assigned task number and drives the 
selected TASK REQUEST n line to the processor. 

The processor sends the following signals to the de- 
vice in addition to the normal I/O bus and clock; 

CURRENT TASK (the task which the executing 
microinstruction belongs to) 

NEXT NEXT TASK (2 clocks ahead of CURRENT 
TASK) 

DISMISS (current task says to clear wakeup) 

TASK-SPECIFIC FUNCTION (communication 
from microcode to device) 

TASK STARTUP DISPATCH (DMA-READ, 
DMA- WRITE decodes of this) (conununication 
from device to microcode, driven if NEXT NEXT 
TASK matches assigned task) 

The processor synchronizes the incoming TASK 
REQUEST lines into a register, clocked by the normal 
microcode clock. The register is ANDed with a de- 
coder which generates FALSE for the current task if 
DISMISS is asserted. The results go into a priority 
encoder. The output of the priority encoder is com- 
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pared with current task. If they differ, and the micro- timing relative to them is controlled by Lisp code or 

code is asserted TASK SWITCH ENABLE, and the special formatting microcode. 

machine did not switch tasks in the previous cycle, then Head selection is the same except that it is done by 

it switches tasks in this cycle. During the second half of microcode rather than Lisp code so that an I/O opera- 

the cycle, NEXT NEXT TASK is selected from the tion may be continued from one track to the next in a 

priority encoder output rather than CURRENT cylinder without missing a revolution because of the 

TASK, and the state of that task is fetched. There do- delay in schedulmg a real-time process to run some Lisp 

esn't appear to be a useful place to use a PAL here. ^ode 

When DISMISS is done, WAKEUP does not clear lo Read/write operations are done by disk control hard- 

mitil the end of the cycle, which means it is still set m ^^^ -^ cooperation with microcode. There is a state 

the synchromzer register. However the output of the ^^^^in, ^^^^ ,^3 ^^^ „^^^^^^j ^^ 

pnonty encoder wmn^^^^ be looked at dunng the ^he drive (i.e. read gate and write gate), controls the 

cycle after a DISMISS, smce we necessarily switched ™„„^„x„ +*i, - ^ ^ i . ^ r ^ 

, , . ^, . , ^ 1^ requests to the microcode task to transfer data words 

tasks m the previous cycle. ^^ • 7 x x- • , , , „ 

xjr- • J 1 r xt/AXTT-TTTi ..• • "^to or out of mam memory, and controls the ECC 

Minimum delay from WAKEUP settmg to startmg . , 

execution of the first microinstruction of the task is two „« "i. T-™^-n . . . ^. , , ^ 
cycles, one to fetch the task state and one to fetch the , ^^f '^^ ^^ "^ usmg the disk, the first two func 
microinstruction. This can be mcreased by up to one ,, Tl f""^" ^^ Performed by LIL code m the FEP; the 
cycle due to synchronization, by one cycle due to just ^^^ ^^^*'°° !' performed by the disk state machine in 
having switched tasks, and by more if there are higher- cooperation with the FEP's high-speed I/O buffer, 
priority task requests or the current task is disabUng ^^ ^^^ ^^^^ machme can select its clock from one 
tasking (e.g. tasking is disabled for one cycle during a ^^ *^^ unsynchromzed clocks, both of which come 
memory access). Max delay for the highest priority task 25 ^^^^ ^^^ ^^^k. One is the servo clock and the other is the 
is then 5 cycles or 1 microsecond, assuming tasking is ^^^^ *^^°^^' derived from the recorded data. Servo clock 
not disabled for more than one cycle at a time. ^^ always valid while there is a selected drive, it is spin- 
When the microcode task is performing a more com- ^S» and it is ready. Delays are always generated from 
pHcated service than simple DMA, the WAKEUP ^^® ^^^^ ^^^^^^ ^°* ^^^^ the machine clock or one- 
flip/flop in the device must remain set until the last shots. 

microinstruction to keep the task alive. '^e state machine is started by an order from the 

The FEP boots the machine from a cold start by microcode, Lisp code, or the FEP and usually runs until 

readmg a small bootstrap program from the disk, load- t°^^ t° ^t^P- When an SMD is being used, most of the 

ing it into the system microcode memory, and executing 35 ^"^^s on the disk bus, including control tag, come from 

it. Before loading the bootstrap program, the FEP per- ^ register which must be set up beforehand, but the 

forms diagnostics on the data paths and internal memo- ^^ad Gate and Write Gate lins are OR*ed in by the state 

ries of the processor. machine. 

Error handling works by having the FEP report The state machine stops and sets an error flag if any 

error signals from the system processor. If the errors ^ ^^ ^^^ following conditions occurs: 

come from hardware failures detected by consistency No disk selected (SMD) 

checks (e.g., parity errors in the internal memories) then Multiple disks selected (SMD) 

the processor must be stopped. At this point the FEP Disk not ready (Priam) 

directly tests the hardware and either continues the 45 Overrun (slow response from microcode) 

processor or notifies the user. If the error signals are An unexpected index or sector pulse 

generated by software (microcode or Zetaiisp) then the Writing the command register while the state ma- 

FEP records the error typically, disk or memory er- chine is running 

rors). These error checks prevents clobbering an entire 

Periodically, the system requests information from ^^ track if the microcide dies for some reason and never 

the FEP and records it on disk, to be used by mainte- sends the stop signal. 

nance personnel. Since the FEP always has the most Other errors from the disk, such as Of Cylinder, are 
recent error information, it is possible to retrieve it not checked for. Most drives will cause a fault if any 
when the rest of the machine crashes. This is especially 55 error occurs while writing. The disk error status (in- 
useful when a recent hardware malfunction causes a eluding fault) is checked by microcode and by mac- 
crash. Since the error information is preserved, it can be rocode after the sector transfer is completed, 
recovered when the processor is revived. The state machme can hang if the clocks from the 
Functions are divided into three categories according disk turn off for some reason. The macrocode should 
to their real-time constraints: 60 provide a timeout. 

Unit selection, seeking, and miscellaneous things like The following orders to the state machine exist, i.e. it 

recalibration and error-handling are done by Lisp code. has the following program in its memory: 

There are I/O device addresses (pseudo-memory) whic Read: The state machine delays, turns on read gate, 

allow sending commands to the disk drive and reading ^5 delays some more, changes from the internal clock to 

back its status (and its protocol, e.g. SMD, Priam). the disk bit clock, waits for async pattern, then reads 

When formatting the disk, the index and sector pulses data words and gives them to the microcode until told 

are dkectly read from the disk through this path and the to stop. The stop signal is issued simultaneous with the 
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10 



15 



acceptance of the third-to-last data word by the micro- 
code task. After reading the last data word, the ECC is 
read, and the microcode task is awakened one last time 
as the state machine goes idle. The microcode reads the 
ECC-0 flag over the bus; the flag is 1 if no error oc- 
curred. 

Read Header: The state machine waits for a sector 
pulse, delays, turns on read gate, delays some more, 
changes from the internal clock to the disk bit clock, 
waits for async pattern, reads one data word (a sector 
header), turns off read gate, and falls mto the Read 
program. The header word is given to the macrocode as 
data (32 bits of header and 4 bits of garbage); it is up to 
the microcode to do header-comparison to make sure 
that the proper section is being accessed. There is no 
ECC on the header, instead there are some redundant 
bits which the microcode checks in parallel with the 
real bits. In other words, the header consists of 6 bits of 20 
sector number, 6 bits of head number, 12 bits of cylinder 
number, and 4 bits of some hash function of the other 
bits, fitting into the 28-bit header stored in a DCW Ust. 

"Memory-mapped" I/O is used for all functions ex- 
cept those relating to the DMA task. This allows the ^^ 
FEP to read from the disk simply by doing Lbus opera- 
tions, with no need to execute microinstructions (the 
CPU however must be stopped or at least known not to 
be touching the disk itself). No provision is made for the 
FEP to use the disk when the Lbus is non-functional. 

Command Register: This register directly controls 
the bus, tag and unit-select lines to the disk(s), provides 
a DMA task assignment, and selects a state-machine 
program to be executed. If the state machine is running 35 
when the command register is written, it is stopped with 
an error. Otherwise it may optionally be started (if bit 
24 is 1). Writing the conmiand register resets various 
error conditions. All bits in the conmiand register may ^ 
be read back. All bits in the command register except 
the low 8 are zeroed by Lbus Reset. 
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15:12 
19:16 
23:20 
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Disk. bus. 

Obus in 

SMD: tage 3:0 

Unit number 

Command opcode (selects state machine 

program) 

Start. Starts state machine if I. Reads 

back as -DISK IDLE (1 if state machine 

running). 

Task. 8-15 selects that task, otherwise no 

task. 

FEP using disk. Enables SPY bus DMA. 

32-bit mode (forces fixnum data type in high 

bits) 

(spare) 
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Read clock 


1 


Servo clock 


2 


Read data 


3 


Index 


4 


Sector 


7:5 


(spare) 



Paddle Enable Register 

This register is cleared when the machine is powered 
on. It allows the paddle board to be turned off. It is set 
to 10 for normal operation. The bits are: 



Paddle ID enable (paddleboard lO prom to disk bus) 

1 Paddle disk enable (disconnect disk part of 
paddle board) 

2 Paddle net enable (disconnect network part of 
paddle board) 

3 Paddle power OK (enable disk to spin up) 



Status Register 

Readmg this register reads the status of the selected 
drive, of the disk interface, and some internal diagnostic 
signals. 

Overrun and Error are cleared by writing the com- 
mand register (however writing the command register 
while the state machine is running will set Error and 
stop the state machine). 

Rotational Position Sensing 

This is a 16-bit register with 4 bits for each deive, 
containing the current sector number. 

Error Correction 

If bit 15 of the status register is after a read opera- 
tion, an ECC error was detected. The error-correct 
state machine operation may be used to compute the 
error syndrome. The microcode task wakes up every 32 
bits, simply to count the bits. After the state machine 
stops, the error correction register may be read: 



10:0 
15:11 



Error pattern 

Bit number within the word 
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DMA Transfers 

A microdevice write operation is done during the 
address cycle. At the same time the sequencer is old to 
dismiss the task and the memory control is told to start 
the appropriate (read or write) DMA cycle. Bits in the 
Lbus device address are: 
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9:5 
4:3 
2:0 



card slot number 
subdevice (0-disk) 
operation 



A task wakeup occurs if the state machine orders one, 
and whenever the state machine is not nmning. No task 
should be assigned by the conunand register when the ^ 
state machine is not being used. A wakeup will always 
occur immediately when a task assignment is given. 

Diagnostic Register 

This register allows a program to disable the paddle 55 
board and simultate a disk, testing most of the logic with 
the machine fully assembled. This register is cleared 
when the machine is powered on. 



Operations: 



write disk buffer directly (rev 2 and later) 

1 dma cycle (start dma cycle without dismission) 

2 dismiss, task acknowledge (just clear wakeup) 

3 dismiss & dma cycle 

4 dismiss (only) 

5 kill disk task 

6 dismiss, task acknowledge, set end flag 
7 dma cycle & set end flag & dismiss 
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Operation 3 is what is nonnally used. Operation 1 18 and alternatively drive the left and right or lower 

could allow transferring multiple words per task and upper memory devices. The read and write signals 
wakeup if there was more than 1 word of buffering: it is , for the memory checks have been set forth with respect 

also probably needed by the microcode in order to start ^ to the description of the Lbus timing modes earlier and 

a DMA transfer for the disk while continuing to run the will not be repeated herein, 
task. The memory is laid out so as to be interleaved with 1 9 

Operation 2 is used for non-data-transfer task wake- bits of address. 8 bits of address are used to select a row, 

ups, such as the wakeup on sector pulse and the wake- 8 bits of address are used to select a column and the 

ups used to count words when doing ECC correction. ^^ three remaining bits of address data are used to select 

It simply dismisses the task (clears wakeup), and also sectors through 7 as shown in the lower left hand 

has different timing with respect to the Overrun error. comer of FIG. 11. 

Operation 5 clears the disk task assignment, prevent- As a result of this interleving configuration of the 
ing further wakeups, clears control tag so that the next 15 . memory, with a judicious storage scheme under micro- 
disk command can be given cleanly and also "acciden- code control, it is possible to pipeline requests for data 
tally" clears fep-using-disk and disk-36-bit-mode. from the memory and write data into the memory in the 

When reading from disk into memory, after the dma block mode discussed hereinbefore, 
cycle with the end flap there will be two additional data FIG. 14 shows the data output buffers of the memory, 

words; the state machine will then read and check the and FIGS. 15 and 16 illustrate the tristate data drivers. 

ECC code and then stop. ; FIGS. 17-18 illustrate the address drivers, FIG. 19 is 

When writing from memory to disk, the data word the address buffer register and decoders and FIGS, 
supplied with the end flag is the second-to-last data 20-23 illustrate the memory control signal circuitry. 
word in the sector; the state machine will accept one 25 Th® combination of the synchronous pipeline mem- 
more data word, then write the ECC code after it, write o^y* microtasking, micro DMA and centrallized ECC is 
a guard byte, and then stop. The same timing applies for believed to be particularly advantageous m that it elimi- 
read-compare. ^^*®^ ^ DMA for each microdevice that wants to issue 

For microdevice read, the bits in the Lbus device ^ a request to the memory and it also eliminates the use of 

address are: ^^^ circuitry on each board of the system. 

The synchronous pipeline memory, microtask and 

_^_^^_^^^^^____^_____.^^..^________^__ micro DMA features combine to enable micro sequenc- 

9:5 card slot number ing between an external peripheral and the memory of 

4:3 subdevice (0-disfc) -t. * • xt_ t^t-«t» -^i ^i . , . 

2:0 operation (0 for disk - read data buffer). 35 the System Via the FEP With the error correction tabng 

place within the active cycle of the bus timing whereby 

the microdevice which is requesting data from the 

FIGS. 10-23 are schematics of a memory board hav- memory is not impacted. This combination of features 
ing 5 12K by 44 bits of memory storage and constituting allows an external I/O device to issue a task request and 
the m^ memory of the system accordmg to the present 40 for the microtasking feature of the system to effect the 
invention. data transfer in a block mode. 

The memory comprises a board of 64K ram chips as It will be appreciated that the instant specification 

shown in FIG. 10 and which are laid out on the memory and claims are set forth by way of illustration and not 
board in the manner set forth in FIGS. 10-23, that is in ^g limitation, and that various modifications and changes 
Cols. 1-16 and 19-34 and rows A-M. The address driv- may be made without departmg from the spirit and 
ers are centrally located m the columns marked 17 and: scope of the present invention. 

APPENDIX 

F:>1mach>ucode>B£TTER-SPRINTER,LISP.17 

;;; -*»- flodetLtsp; Packdge:ni cro; BasezS; Louercasetgas -«- 
t;; (c) Copyright 13S2, Sgnboi ics, Inc. 

; "If I have seen less far and less clearly than others, it Is £?ecau8e 
; giants were standing on sg shoulders." — Sir Isaac Ufdfield 

tdefvar «t3s-Hi^ ths«) 

(defvar »t!?-ct. ... ! -mi ser-uidths*) 

(defvar «r:s--.' s'pr-uidths*) 

Idefvar »D5- •: 31 sizes*} 

(';: ' var *l«u- * ; ne ' » SB. ) 

(defur better-.pr inter (form) 

(tetter-sprinter-1 f orft) ) 

(defun better-spr inter-! (form) 
(let ((«D5-uidths» ni t) 

(¥bs-semi-«iser-width8» nil) 
(*t)9-ffiiser-uidths* nil) 
(»bs-fiajsi2es» nil) 
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tfn (strea.r. (if > (car outf i les) tyo))) 
(bs-ppint for* (bs-charpos) W1 (Itnei 8tp«a») <fQ *bs-l inal«) 

(defun bs-charpos 
#n (charpos (if '^p (car outf ties) two)) 
ml (funcail standard-output • :read-cup«orpo8 'ichapactcr)) 

(defun b9-flatsize (form &aux te«) 

(cond ((setq tent (assq for» »b8*f iatsizes*) ) 
(cdr tem)) 
Ct (setq tea (ftatsize f or») ) 

(push (cons fora tea) vos-f iatstzes*) 
tea)}) 

(defun bs-width (form <iaux tea) 

(cond ((atom fora) (bs-flatsize form)) 

((setq tem (assq fora «b9-widthc*) ) 

ic6r tea) ) 
(t (cetq tea (bs-width-1 fora)) 

(push (cons fora tea) sbs-uidthea) 
tem))) 

(defun bs-semi-ffiiser-utdth (fora iaux ten) 
(cond ((atom fora) fbs-flatsize form)) 

((setq tea lasaq fora »ba-se«(-aiser-widths*n 

(cdr tem)) 
((nuM isetq tem (bs-foraat form))) 

(bs-uldth form)) 
(t (setq tem (bs-uidth-3 iorm terr)) 

(push (cons fora te«) *bs-aemj-ai«er-u(dths«} 
tea) J ) 

(defun bs-miser-width (form &3ux tea) 
(cond ({atom form) (bs-ftata<ze form)) 

((setq tem (assq fora *bt-ai ser-widths») ) 

(cdr tem)) 
(t (setq tea (bs-uidth-2 form)) 

(push (cons fora tea) «bs-aiser-uidths«) 
tea))) 

(defun bs-width-2 (form) 

(1+ (loop for I « form then (cdr t) ;1+ for Icadino open paren or tpaca 
when (and (atom I) (not (null O)) w t- r h 

maximize (+ (bs-utdth I) 3) ftxnua sdot ep close 
whi te (not (atoa !)) 
when (cdr I ) 

maxiaizd (bs-width (car I)) fixnua 
else oaxioize (1+ (b«-width (car I))) fixnum))) ;+l for close 

(defun bs-width-1 (fora &aux (fat (bs-foraat fora))) 
(cond ( (nul I fmt) 

(+ (bs-width (car form)) 2 t2 for open paren and space 

(loop for I m (cdr form) then (cdr J) 

when (and (atom I) (not (null \))\ 

aaxinize (+ (bs-wIdth I? 3) flxtnum tdot ep cfose 
whi /e (not (atoa il) 
when (cdr U 

aaxiaiie fbs-wtdth (car !>> flxnum 
else aaxictze (1+ Cbs-width (car 1))) ;!+ for close paren 
fixnum))) 
(t (let {(head (car fmtM 

(n-cer-line (cadr fmt))) 
(+ Ooop for x in form repeat head 

sum (It (bs-flatsize x)) fixnura) 
(i f izcrop head) 8 1) 

(locp for I - (nthcdr head form) then It until (null I) 
as I 1 • (nthcdr n-per-line I) 
maximize (+ (if i! -10) ; f or close paren 

.„ „ _, [l5^P ^^^ ** ''^ ' repeat n-per-ltne 

(defun bs-width-3 (fora fat) 
(lat ((head (car fmt)) 

(n-per-lrne (cadr fat)) 
(indentation (caddr fat))) 
(aax (loop for X in fora repeat head 

, sum (1+ (bs-flatsize x) ) fixnua) 
(+ indentation 

(loop for I » (nthcdr head form) then II until (null I) 
•s I I • (nthcdr n-per-lin© 1} 
aaxiaize (+ (if II -1 e) ;for close paren 
(loop for X in I repeat n-per-line 

^- ivif^" ^^^ (ba-seai-aiser-width x)) fixnua)) 
f 1 xnum) ) ) ) } 

(defun bs-foraat (form) 
(and (not (atom form)) 

(not (dotted-p form)) 
(if (symbolp (car fora)) 

(get (car fora) 'bs-format) 
(8 1 1)))) jGood for eelectq clauses at least 
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(defun bs-prtnt (form indent (inol) 
(if (atom form) (prinl form) 

Met ((fBt (bs-fopiaat for*)) 

(epace (- line! indent))) 
(cond ((and (op (null fmt) (not (eymbolp (car fopa)))) 
(<- (bs-flatsize fopa) space)) 
(prinl form) ) 
((<» (be-uidth fopa) epace) 

(bs-print-1 fcpa indent line! fut)) 
((and fmt (<- (bo-sea i -a i sep-width fora) space)) 

(b5-ppint-3 fopa indent line! fat)) 
(t (bs-aiaer fopa indent linel)))))) 

(defun bs-ppint-l (fopa indent linsi fnt) 
(ppinc "(") 
(cond ((nuM fmt) 

(b«-print (cap fopm) (1+ indent) linel) 

(ppinc " ") 

(setq indent (bs-chappos) ) 

(loop fop I • (cdp fopa) then (cdp I) 

when (and (atoa t) (not (null I))) 

do tprinc ^ •) (bs-ppint I (+ indent 2) linel) 
wht le (not (atoa 1) ) 
do (bs-ppint (cap t) indent ttnel) 
when (cdP I) do (bs-tepppi indent))) 
(t (let ((head (cap fmt)) 

(n-pep-line (cadp fmt))) 
(bs-pow-of fopm head (1+ indent) linel) 
(op (zepop headJ (ppinc " **)) 
(setq indent (bs-chappos) ) 

(loop fop I - (nthcdp head fopm) then II until (null I) 
as I I - (nthcdp n-pcp-Iine 1) 
do (bs-pow-of I n-pep-IIne indent linel) 
/«.-«. -^.^^ unless (null M) do (bs-t«pppi indent))))) 
I pp I nc / )) 

(defun bs-ppint-3 (fopa indent line) f»t) 

(princ "(") 

(let ((head (cap fnt)) 

(n-pep-l tne (cadP fmt)) 

(indentation (caridp fmtM) 

(bs-pou-of fopm head (1+ indent) linel) 

tsctg indent (+ indent indentation)) 

OP (zepop head) (null (nthcdP head fopm)) (bs-tepppi indent)) 

(loop fop i • (nthcdr head fopm) then It until (null I) 

as I I • (nthcdp n-pep-iine t) 

do (bs-pou-of I n-pep-line indent linel) 

/ * -V? ?** ^""** "^ =^° (bs-tepppi indent))) 
(pp I nc *)'*)) 

(defun bs-pou-of (list n indent linel) 
(op (zePop n) 

(loop fop X in list as » upfpom 1 
do (bs-ppint X indent linel) 
unti 1 (• i n) 
do (ppinc " ") (setq indent (bs-chappos) ) ) ) ) 

(defun bs-tcpppi (indent) 
(teppr i ) 

(loop repeat (// Indent S) do (tuo iSfXtab)) 
(loop pcpeot (\ indent SJ do (tyo A'Vsp) M 

(defun bs-mlsep (form indent linel) 
(cond ((atom fopm) (prinl f opm) ) 
(t (ppinc "(") 

(setq indent (1+ indent)) 
(loop for I - form then (cdr I) 

when (an d (atom I) (n ot (null I)) ) 

F:>lmach>ucode>check, 1 isp. 116 

;;: -*- Hode:Lisp; Pack.aqe:nicpo; Base:8; LouePcase:yes -«- 
j;; (c) Copypight 13S2, Symbolics, Inc. 

; Hicpocode Syntax Checking 

;This IS an atist of all fields. 

;cap of an entry is the name of the field 

;cadp is a list of other fields pcquiped; elements are eithep names 

; of fields, op Msts of name and acceptable values 

;caddr is value checX,tng for this field: nil to accept any value or 

; a predicate which retupns t if the valve Is QK, op a list of valid values 

;Note that some values for scffiis of these fie/ds are redundant with 

; the spec and/op magic fields. 

(defconst val id-micpocode 

*((abus (amem memory-data frame-po inter stacK-poJnter Ibus 
memopy-data-fopce vfr,a pc map -on THC machine 

(amem-pead-addp ((atous amen memopy-data) ) check-amem-addp) 
(bbus U- \bmem macpo-s igned- immsd i ate macro-unsigned-immediate)) 
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{bmem-read-addp t ibbus bmem/ ) chfick-bmera-addPi 

iur i te-amem (amem-wr i te-addr) (cbus) ) 

{a»em-wr i te-addr check-amem*non-constant-addr) 

iur i te-bmem (bmem-ur i te-addr) (xbus obus) ) 

(bmcm-uiri te-addr (ur ite-bmem) numberp) 

(write-Ibus (obus memory-data junk)) 

( Ibus-dev-addr check-lbus-dev-addr) 

(xbus (abus bbus product)) 

(ybus {) (abus bbua ybua-crocks-l ybu9-crock9-2) ) 

(aiu check-alu-func) 

(byte-func () check-by te-func) 

(force-obus<35-3^> () (0123 abus bbus bbus<7-B>)) 

(foPce-obu9<33-32> (3123 abus bbus bbu5<5-4>)) 

(force-obusc31-2S> O <a 1 2 3 4 5 6 7 10 11 12 13 14 15 16 17)) 

(type-msp check- tyoe-map) 

(stack-pointer () (increment decrement^ 

(spec (toad-byte-p load-byte-s ioad-stkp load-frmp 

load-Kbas load-control tcad-speciai-maps clear-stack-adjustment 
ar I thmet tc-tpap-enb trap-i f-type-cond 

trap-i f-tupe-cond-ar-bbus-not-f ixnuw mul t tply-and-type-check 
crocks aiub-»i go-hack crocks- to-ybus multiply 
addr-from-abua mhibi t-page-tags dma address-phtc 
check-ur 1 te-access increment- inst ifu-contro( 
ar (thmet tc-trap-with-di spa tch halt npc-magic awaken- tack 
urite-task di sable-tasking) ) 
(magic (0 1 2 3 4 5 S 7 10 11 12 13 14 15 IB 17)) 
(magic-mask (maaic) (1 2 3 4 5 6 7 10 11 12 13 14 15 16)) 
(dispatch (dispatch-table magic) 

(aiub cdr-code abus<31-28> abus<25-22> 
abus<21-18> abus<2-0> bbus<31-30>-abus<31-30>)) 
(mem (ur i te-vma start-cycle ;proto 

microdevice start-read start-writ© write-vma bfock-read b(ock-ur i te) ) iTMC 
(escape-to- I i so () nil) 
(error-table () nil) 
(deciare-memory-t iming (> nil) 
(condition {} 

tnot-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3 
type-condition bbus-not-f txnum alub-0 ybus-31 
not-gc-condemned-temp not-gc-this-stack not-gc-other-stack 
equal -pointer 

not-equa(-f txnum not-equa(-tuped-potnter 
r.ot-qreater-po inter not-greater-f ixnura-unsigned 
alu-3l sequence-break trace-flag-1 trace-flag-2 
not-Ibus-dev-cond «c-cond not-ctos-came-from-t fu 

(sequencer (popj next- instruct ion pushj pop push-npc pop-npc 

dismiss pop-npc-and-cpc-from-npc 

take-dispatch pushj-return-dispatch)) 
(trap-enables check-trap-enablcs) 

(skip-true-sequencc (condition skip-false-sequence) 

check-skip-sequence) 
(skip-false-sequence (condition sk ip- true-sequence) 

check-skip-sequence) 
(re turn- true-sequence (return-false-sequence) 

check-ski p-sequen'ce) 
(return-fat se-sequence (return-true-sequencei 

check-skip-sequence) 
(return-skip (t)) 
(jump-sequence (} check-next-sequence) 
(next-sequence {)■ check-next-sequence) 
trap-sequence (trap-enables) check-trap-sequsnce) 
(d)Epatch-table (dispatch) check-dispatch-table) 

ar I th-trap-dispatch-table (spec trap-enables) check-dispatch-table) 
(unique (t)) 

(speed (slow-first-half slou-second-hal f slow very-slow)))) 

;Each elerrtent is a list of (field value) pairs where if the first 
:cne ts present, the others are disallowed, 
Idef const microcode-f ie Id-con f I icts 
'(((xbus abuc) (ybus abus) "Xbus and Ybus sources not independently selectable") 
xbus btus) (ybus bbus) "Xbus and Ybus sources not independently seie-table") 
sequencer next- instruct 1 on) (spec ifu-control) "Next inst not ready") 
t^stjus vma) tmem start-rea d start- write block-re ad block- write) 
■Reading VMA uses ADDR outputs'') ~~~~" 

((abus Ibus) (ybus abus) 
"nicrodcvice read is just too slow, «u8t go into the fast side of the ALU") 

^ (declare (mixpr fitldpT) ^;in"UU " -^_— - __ 

(declare (special ^backtrace*) ) ; in UU 

(defvar «cod.*) ;So 1 can see the microinstruction being checked 

(defun check- loses (format 4rest arga) 
(declare (special args)) 

(let ((^wnil) (^r ntt) C^qniD) .rcAD 

(terpri msgf i les) .t-^~f 

(lexpr-funcall «r* format msgf i les format args) 
format msgf I les "^;^U<^2:-:; in -^S-v>^) -v?" «backtracB*) 
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(defflavop check-loses (forp.at-str Ing format-args code) 

. .^ , . ^ ^ysino-action-BlxIn dbgrspecial-cofflmands-mixin error) 
: ini tatjie-instance-var taoies) 

{defmethod (check-loses treport) (stream) 

(lexpr-funcal i #' format stream format-string forraat-args) ) 
Pu . ^ » 

(defmethod (check-loses jcase s special-command :show-fai I ing-nicroinstruct ion) 
^'Fretty-print the micro instruct ion that failed" 
(ppx code) 
nit) ;N1L means stay in the debugger 

(push ' (rshou-fai 1 ing-microinstruction tf\c-8h-P) dbg:«special-cofflmand-special-keys«) 

(compi le-f lavor-methods check-loses) 

(defprop check-loses t zerror-reporter) 

(defun check-loses (format-string irest args) 

(signal *check-loses [ : format-str ing format-string 
': format-args (copyiist argsf 
scode «code*) ) 

(defun check-conflict (code fteldl fie!d2 fioptional message) 
(check-loses "-^aC^A^i^] (^S ^S) conflicts with (--S ^S)" 

■Jessage fielol (get code fietdl) field2 (get cods fieldZ))) 

(defun check-amem-addr (addr) 
( i f (atom addr) 

(and (eq (typep addr) 'fixnum) (<- addr) (<• addr 3777)) 
(seiectq (car addr) 

}iIZ5!l!!:2°'?^*M'I^5*'"^Si"^^?^ ""^^^^ ^*^ ^^yP«^P ^^3^"" acldr)) 'fixnum)) 
(macrocode (null (cdr addr))) 

(constant (val id-constant (cadr addr))) 

(bus-address (null (car addr)))))) 

(defun check-amem-non-constant-addr (addr) 
( i f (atom addr) 

(and (eq (typep addr) 'fixnum) (<« addr) (<- addr 3777)) 
(seiectq (car addr) 

}iI'"^'"-"2°'7**'r,'/^'=*^*^°^"F?r **^"^ *«^ (typep (cadr addr)) 'fixnum)) 
(macrocode (nuM (cdr addr) ) ) 

(bu8-3ddres5 (null (cdr addr)))))) 

(defun check-bmem-addr (addr) 
( i f (atom addr) 

(and (eq (typep addr) 'fixnum) (<« 8 addr) (<- addr 377)) 
(and (eq (car addr) 'constant) 

(valid-constant (cadr addr))))) 

(defun valid-constant (val) 
(or (numberp val ) 
(and (I istp va!) 

(eq icar val) 'build-task-state)))) 

(defun check-lbus-dev-addr (addr) 
(or (numberp addr) 

:; Also used to select flC destinations 
Imemq addr (seiectq ^machine-version* 

((sim proto) ' (uri te-memory)) 

((tmc) ' (urite-phta-and-asn wr i te-vma-and-pc 

M*«^c . "'T'Jfi-'TV'^^P "'"'te-map-a urite-map-b ur i te-both-maps) ) 

ittfflcb I f u) (wr I te-phta-and-asn 

;: Also synbolic card slots"' ""^"""""^^ "rite-map-a write-map-b wr i te-both-maps) ) ) ) 
(and (itstp addr) (get (car addr) 'symbol ic-lbus-slot) ) )) 

(declare (special nornal-alu-funct ions weird-atu-funct ions) ) ; in UU 
(defun check-alu-func (func) 

(cond (imemq func (if (and (or (fieldp «code» ;spec ' ar i thmet ic-trap-enb) 

/w** t'®!*^? *code* 'spec 'ari thmetic-trap-wi th-dispatch)) 
(bit-test ^ (get *code« 'magic))) P^^^nu 

we I rd-a I u-f unct I ons 
normal-alu-funct i ons) ) ) 
((memq func we i rd-al u-funct i ons) 
(check-conflict «code« 'aiu 'spec 
^j "^U function is wierd, but special function and tf not specified") 

((memq func normal -a I u-funct i ons) 
(check-conflict *code* 'aiu 'spec 
^jjj *'^^^ function is normal, but spec says /"ueird ALU function/*'*) 

(defun check-byte-func (func) 

*°^ (^nH^M^l^T^ ^ :Function 2 

(and ( I 1 stp func) 

Upt'^nrot'/.Ii^^nH ^^'"^^^^^^^^ ,... iOther funcs. decided later 
tiet (rot (seccrd func); (ir-.-k (third func))) 

lor (and (eq (typep rot) 'fixnum) (<- e rot) (<- rot 37) 
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ieq (typep mask) •fixnuiti) (<- 1 r.ssk) (<• mack A3)) 
(and (eq rot byte-r) 

(or (eq mask *byte-s} 
/ -. / ^®? (typcp mask) 'fixnuni) (<- 1 sask) (<- nask 40))) 
(and (cq rot 'eiacro) (cq mask *macpo)))) 
(or (nul ! (cdddr func) ) 

(eq (csdddr func) •nerge))))) 

(declare (special *data-type£« *cdr-codes»)) ;mSin 

;Check that Xyoes are valid, outputs are one of the 8 possible combinations. 
;and no types are duplicated ' 

(def const tupe-fnap-possibl I i t ies 

MO (cond) (pointer) (pointer cond) 

(trap-e) (trap-1) (trap-2 painter) (trap-3 pointer) 

;At ternate spe ( f ings 

(cond pointer) (pointer trap-Z) (pointer trap-3) ) ) 

(defun check-type-map (x) 

(loop for ((tupes . outputs) . rest) on x 
always (loop for tp in types 

always (memq tp *:data- types*) 
always (loop for itZ . o2) in rest 
never (meinq ip t2))) 
always (member outputs type-map-possibi M t ies) ) ) 

;This is not one field in the real machine. Some of these are inside the 

: type map, also, 
(defun check-trap-enables (x) 
{ loop for en in K 

always (memq en '(condition-true condition-false any-stack other-stack 
type-condition Dbus-non-f ixnum overflow 
transport map-niss)))) 

:Try to prooaoate memory timing through skips. 

'il^i' is smart enou-h to get it in, but too dumb to know how to get it out aaain 

(defun check-skip-sequence (seq memory-timing) -yam 

(cond (null seq)) :drop-through 

(symfcolp seq)) .jump tag 

tn?^ '*^''°^°'^* '*^ s*itp-scquence menjory-timing) ; literal code 

(defun check-next-reqtjcnce (seq) 

(cond ((sumboip seq)) .jump tag 

It (cnecK-ftiicrocode seq * next-sequence) ; literal code 

(defun check-trap-sequence (seq) 

(cond ((sufT.boip seq)) * jump tag 

(t (check-microcode seq 'trap-sequence) ; literal code 

(defun check-dispatch-table (table) 

(check-loses "Not table of dispatch clauses: *.S" table) 
(loop for clause in table 

unless (eq (car clause! ^otherwise) 
do (loop for cue in (car ciause) 

unless (numberp cue) -good enough check for now 
^ 1 ^ ,f .^° check-loc=3 "^S invalid dispatch cus" cue)) 
do (cond ((atom (cadr clause))) ;noto 

(t (check-microcode (cadr clause) 
^) * (dispatch ,(car clauce)))) ) ) ) 

(defun check-microcode («code« where iopt tonal memory-timing) 
(let ((«back trace* (cons where xback trace*) ) ) 

(cond ((and (not (atom «code»}) (eq (car »code») 'micro instruct ion)) 
(check-m'tcrocodel «code* memory- ti mi ng) ) 
((and (not Utom *code»)) (eq (car »code») 'nicrosequence)) 
(push 'microsequence ^backtrace*) 
(loop for X in (cdr «code*> 
do (if (and (not (atom k)} (eq (car k) 'microinstruction)) 
(let ((»code« x)) 

(eetq memory-timing (check-mi crocodel x memory-timing) ) ) 
(check-losea "Invalid microcode: -S" x)))) 
(t (check- loses "Unrecognizable microcode: --S" *code«)))}) 

(defun check-mi crocodel (code memory-timing &aux declared-memory-t iming) 
;; First make sure there aren't any misspelled field names, since 
;; those typically cause spurious other messages 
(loop for (field value) on (cdr code) by 'cddr 
when (null (assq field valid-microcode)) 

do (check-loses '-S invalid microcode field name" field)) 
;: Now check inter-field consistency 
(check-f ield-conf 1 icts code) 
(check-spec-and-mag i c-f i e 1 ds code) 
(check-next-address-field-consistency code) 
:; Check the memory timing for temporary memory control 
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<if (setq deciared-neeory-tiraing (get code 'declape-memory-t iiiing) ) 

(setq Be«ory-ti»ing deciared-raeniopy-t iaing) ) 
(and (fieldp code 'abua •memory-data) 



^ memory- 

(not (aewq 'data-cycle memory- t i wing) ) 



(check-loses 'Reading ttO but netnopy is not in data-cycle (it's in *S) ' 
(and (fieidp code ' Ibua-dev-addr 'ur i te-»emopy) 

(not (memq (get code '■em) * (start-cycle start-write block-write))) 
(check- loses "Storing into wemoru without starting a cycle") } 
Compute Bemory-t i Bing value for foTlouing cycle 



•eaory-timing) ) 



y-ti^Bing value for fotloutng eye 

;fe) dectared-aeworu-timinq) 

ead))}) 



(let ((next-active (or (member Mnext active-cycle) dectared-aemory-timing) 

(memq (get code 'wera) * (start-cycle start-read block-r 



(next-data (or (memoer '(next data-cycle) dectared-nemory-tiaing) 
(»emq 'active-cycle •enory-tiaing)))) 
(setq »emory-t iaing (if next-active 

Irf next-data '(active-cycle data-cycle) Mactive-cucle) ) 
_ ._ (if next-data • (data-cycTe) nil)))) 

;; On inc aachine, aake sure that aicrodevice read/write is going in the proper 
;; direction. Using Lbus as the Abus source implies aicrodevice read, 
(cend ((memq «raachine-version» '(two tmc5 ifu)) 
(and (get code *wrrte-Ibus) 

(fieldp code 'abus 'lbus) 

(check-toses "Lbus as Abus source incompatible Hith aicrodeviceZ/VHA write")) 
(and (get code write- 1 bus) 

(not (meiDq (get code 'mem) '(aicrodevice write-vma)}) 
(check-loses "URITE-LBUS without tlEn// niCRODEVICE or l«ITE-VnA")) 
(and (neq «machine-version« 'ifu) 

(fieldp code 'write- 1 bus 'obus) 
(fieldp code 'abus 'memory-data) 

(check-loses "URITE-LBUS from OBUS but ABUS source is nEraRY-OATA;*« 
,, ^ , ,. . . T"C machine will write from MO rather than OBUS!")))) 
;; Now check field values, and successor Instructions 
(loop for (field value) on (cdr code) by 'cddr with tea 
as d - (assq field valid-microcode) 
when (nul I value) 

unless (memq field ' (skip-true-sequence skip-false-sequence) ) tdrop-thr 
do (check- 1 OSes "-S field has NIL value" field) 
do (loop for c in (cadr d) 
when (atom c) 

do (or (loop for f in (cdr code) by 'cddr there! s (cq f c) ) 
(check- 1 OSes "*S field missing when *S -S present" 
c field value)) 
else do (or (member (setq tern (get code (car c))) (cdr c)) 
(check- 1 OSes 
"'^'S field has value ^^S, invaMd when *S *S present" 
(car c) tem field value))) 
as checker - (caddr di 
unless (cond ((null checker)) 

((symbolp checker) 
(if (memq field ' (skip- true-sequence skip-fa I se-sequence 

return-true-sequence return-fal se-sequence) ) 
(funcal! checker value memory-timing) 
(funcall checker value))) 
(t (member value checker))) 
do (check-loses "*S illegal value for ^S field" value field)) 
memory-t iming) 

(defun check-field-conflicts (code) 

(loop for ((fl vl) (f2 . exclusions) reason) in «icrocode-f leld-conf I lets 
when (ea (get code fl) vl) 

when (memq (get code f2) exclusions) 
do (check-conflict code f2 fl reason))) 

:I^^°^^®C *^»'^9 ''"P'y values of these, check that they are really there 

(defun check-spec-and-magic-fields (code &aux tem temU 
(and setq tern (get code ' f orce-obus<31-28>) ) 
(not (fieldp code •magic tem)) 

(check-conflict code ^force-obu3<31-28> 'magic)) 
(cond ((or (fieldp code 'ybus 'ybus-crocks-D 
ft el dp code 'ybus •ybus-crcck8-2) ) 
(or (fieldp code 'spec 'crocks-to-ybus) 
.. Jp.x^^t^r^^^^'^ct code 'utjus 'spsc)) 
jU AHUA <n> must also be free 
(if (get code 'stack-pointer? 

check-conflict code 'ybus 'stack-pointer "U AMUA <11> conflict")) 
(if (numberp (get code 'amem-wr i te-addr) ) 
(cond ((fieldp"code°'xbur 'amem-wr i te-addr "U APIUA <11> conflict")))) 

(or (fieldp code 'spec 'multiply) 

(fieidp code 'spec 'mul t iply-and- type-check) 
(check-conflict code 'xbus snec) ) 
(or (« (logand (^et code 'magic) B) A) 
t ^ ,. <check-conf I ict code 'xbus 'magic)))) 
(cond ((setq tem (get code 'trap-enables)) 
(cond ((memo 'other-stack tem) 

(or (fieldp code 'spec 'crocks) 

(check-conflict code 'trap-enables 'spec 

ir^r^ (»^ ^i t ^ -I "fP-c/Zcrocks needed to enable GC traps")) 
(or (equal (get code 'magic) 2) 

(check-conflict code 'trap-enables 'magic 

"Ka^ic number needed to enable GC traps"))) 
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((memg 'any-stack tern) 
(or (fie I dp code *5pec 'crocks) 

(check-conflict code ' trap-enablee 'spec 

"specZ/cpocka needed to enable GC traps")) 
(or (equal (get code *magic) 1) 

(checv-conf Uct code 'trap-enables 'aagic 

"aagic number needed to enable GC traps"))) 
((memq 'type-condition tein) 
(cond ((menq (get code 'spec) 

• Tar i thnetic-trap-enb ar i thmetic-trap-ui th-dispatch)) 
(or (bit-test 1 (get code 'nagic)) 

(check-conflict code 'trap-enables 'magic 

"tlagic number needed to enable type cond trap"))) 
((rremq (get code 'spec) 

' Ttrap-i f-type-cond 

trap- i f- type-cond-or-bbus-not-f i xnua 
»u 1 1 i p I y-and- tyoe-chcck) ) ) 
(t (check-conflict code * trap-enables 'spec 

"Spec needed to enable type cond trap")))) 
((memq 'bbus-non-f ixnum tern) 
(cond ((memq (get code 'spec) 

'Tar i thmetic-trap-enb 

ar i thmet ic-trap-ui th-dtspatch)) 
(or (bit-test 2 (get code 'magic)) 

(check-conf I tct code 'trap-enables 'magic 

"Magic number needed to enable bbus type trap"))) 
((memq (get code 'spec) 

' Ttrap-i f-type-cond-or-bbus-not-f ixnum 
mu 1 1 i p t y-and- type-check) ) ) 
(t (check-conflict code trap-enables 'spec 

"Spec needed to enable bbus type trap")))) 
((memo 'overflou tem) 
(or (memq (aet code 'aiu) 

MX+1-overflou X-1-overflow X+Y-overflow X-Y-overf low) ) 
(check-conflict code 'trap-enables 'alu))) 
((memo 'map-miss tem) 
(or (fieldp code 'mem 'start-cycle) 

(check-conflict code 'trap-enables *mem 

"Start-cycle not specified in HEU field")))))) 
:; dispatch and magic assumed made consistent at the source 
:; Decide hou to encode the byte func, and check for AMUA conflicts 
(multiple-value-bind (byte-func magic) 
(choose-byte-func-encoding code) 
(let ( (amem-uses-amua (and (get code *ur ite-amem) 

(setq tem (get code 'amem-wri te-addr)) 

(not (equal tem '(bus-address))) ;only uses bit 18 

(or (setq teml (get code *amc»-read-addr) ) 

(setq te?nl (get code 'abus))) 
(not (equal tem teml)))) 
(bmem-uses-amwa (and (fieldp code 'spec 'crocks) (fteldp code 'magic 10))) 
(byte-uses-amwa (and (• byte-func 3) (not (bit-test 3 magix)))) 
( Ibus-uses-amua (get code ' Ibus-dev-addr)) 
(stack-pointer-uses-amua-11 (get code 'stack-pointer)) 
(crocks-uses-amwa-11 (fteldp code 'spec *crocks-to-ybus)) ) 
(if (and amem-uses-amua bmem-uses-amwa) 

(check-conflict code 'amem-uri te-addr 'bmem-uri te-addr 
"Conflict for Ar.UA field")) 
(if (and amem-uses-amua bute-uses-amua) 

(check-conflict code amen-wri te-addr 'byte-func 
"Conflict for AHUA field'')) 
(if (and amem-uses-amua Ibus-uses-amua) 

(check-conflict code 'amem-uri te-addr 'Ibus-dev-addr 
"Conflict for AHUA field")) 
(if (and bmem-uses-amua bute-uses-amua) 

(check-conflict code bmem-ur t te-addr 'byte-func 
"Conflict for AHUA field^)) 
(if (and bmem-uses-amua Ibus-uses-amua) 

(check-conflict code *bmem-wr 1 te-addr 'Ibus-dev-addr 

"Conflict for AHUA field").) 

(if (and byte-uses-amua Ibus-uses-amua) 

(check-conflict code 'byte-func 'Ibus-dev-addr 
"Conflict for AflUA field")) 



Unfortunately, AnUA<ll> conflicts happen alt over the place unless 
ue aiiou both parties to tpectfy the same bit value. This means 
that the Amem variables you urite into while decrementing the 



_ stack pointer must go in a specific half of Amera. 
(and amem-uses-amua crocks-uses-amua-11 

(atom (setq tem (get code *dmem-wr i te-addr) ) ) 

(neq (if (bit-test A0B0 tem) 'ybus-crocks-Z 'ybus-crocks-D 

(get code 'ybus)) 
(check-conflict code 'ybus 'amem-uri te-addr 
"Conflict for AHUA <11>")) 
(and amem-uses-amua stack-pointer-uses-amua-11 

(atom (setq tern (get code 'amem-ur i te-addr) ) ) 

(neq (if (bit-test 4009 tem) 'increment 'decrement) 

stack-pot nter-uses-amua-U) 
(check-conflict code 'stack-pointer 'amem-ur i te-addr 
•Conflict for ATIUA <11>'*))))) 
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;; decide hou to encode the byte-func 
(defun choose-byte-func-encodin9 (code 4aux tern) 
;Return9 bute-func ffeid, Biagic field, waaic-mask field, cond field, and anwa 
i\f (atom Tsetq te» (get code 'byte-func) ) } 
(values 8) ;Pa8s Ybus 

(let ((p (second tem)) 

(s (third tern)) sReaMy S+1 
(r» (eq (first tem) *dpb)) 
imrg (eg (fourth tew) ^iterge)) 
(magic (get code '■agic))) 
(cond ;; Byte function taken care of already (byte-func • ubus) 
;; Byte function 2 (S from COND field) 
((and (equal r 0) (numberp e) (not mrg) (not (get code •condition))) 

(values 2 ni I ni I (1- s))) 
;; Byte function 1, /y2»l case 
((and (equal r 29) (equal s 28) (not wrg) 
(op (not magic) (bit-test 4 uagicJ) 
(or (not magic) 

(and (op (fioldp code 'spec * multiply) 

(fie I dp code 'spec 'mult iply-and- type-check) ) 
(not (bit-test 1 ragic))) iff2 fpee 
(eq pm (bit-test 10 magic)))) 
(values 1 (if rm 14 4) 14)) 
:; Byte function 1, tfZ'^B case 
((and (not magic) (not pm) (not mpg) (equal s 43) 

(membep r '(8 1 37))) ; Could add mope... 

(values 1 (cdp (assoc p M(0 . 3) (1 „ 2) (37 .18)))) 17)) 
;; Hope of that, kludge fop fipst cycle of multiply. Is thepe a bettep wag? 
(and (equal magic 131 (equal r 20) (equal s 20) p« (not mpg)) ^ 

(values 1 13 17)) ^ 

U 9^^!'"^i'® "'? ^V^? ^""?i'2? ?• requires magic numbep field 
(t (let ((mage (+ Tif rm 10 0) (if mpg 4 0))) 
(cond nil) 
(amua nil)) 
(cond ;; Byte function 3, case (R and S fpom AHWA) 
((and (numbcpp r) (numbepp a)) 
(setq amua (dpb (1- s) 0505 p))) 
;; Byte function 3, case 1 (R fpom RREG, S fpom COND) 
((and (eq p 'byte-p) (numbepp a)) 

(setq cond (1- e) mage (+ mage 1))) 
;: Byte function 3, case 2 (ri fpom RREG, S from SREG) 
((and (eq r 'byte-p) (eq s 'byte-s)) 

(setq mage (+ mage 2))) 
;; Byte function 3, cass 3 (R,S fpom Mcpoinatpuction, 
;; high S bita fpom CONO) 
((and (eq r 'macpo) (eq a 'aacpo)) 
(setq mage U mage 3) 
/* / u *^?"^ 'macpo)) ;nuat fill in fpom opcode 
/ J^ (check-ioses I can find no way to encode this byte function'"))) 
(and cond (get code condition) 

(and mag ic'(nSr (/rage 'magi '"'' '^*" '*^""*^°" "'*^°"* "^'"9 ^°^ ^^""= 2)")) 
(valueff mige'" confUwa)) )))))' '"^'^ ^^'" '""=''°" "•*^°"' "'''"^ "AGIC (func 3)-)) 

•^Jf^^^K^V^Tu*^^^ anything which uses the next-addpess field has an explicit 

iaSd wnL! ♦Kf!"T^'*'"*'*°'^'"KX*Ty *° "" •* *° ''"*^ *o t*^e next instpucti 
;and knows that it must use HPC instead. 

(defun check-next-address-field-consistency (code daux tem 
;; Aptthmetic traps pequipe eithep a single tpap routine 
(and setg tem (get code • tpap-enables) ) 
(op (memq | type-condi t ion tem) 
(memq 'bbus-non-f ixnum tem) 
(memq 'ovepflow tem)) 
^kLu^?^' ^°i?? !<t^ap-sequence ap i th-tpap-di spatch-tab I e) ) ) 
-. HiK^D 5ac'?^®' Apithmetic tpap enabled but no tpap handlep specified")) 
;; Other NAF traps Pequtre a single trap routine P c T.ea ;; 

land setg tem (get code * tpap-enables)) 
lor (memq ' cond i t i on-tpue tem) 
(memq 'condition-false tem) 
(memq 'any-stack tem) 
(mem q 'other-stack tem)) 
(not (get code ' tpap-eequence)) 
(check-conflict code ' tpap-enables ' tpap-aequence 
e ^ ,. ... '^^ *'"ap enabled but no tpap handler specified")) 
;; bubpoutine cal hng pequipcs a aubpoutino (aepapata fpom petupn to .+1) 
(and (memq (get code aequencep) ' (push) puahj-petupn-dispatch)) 
(not (get code jump-sequence)) 

(not (get code * ak ip-true-sequence)) ; f op call-select micpo 

(check-conf i ict code sequencer 'jump-sequence 

, ^ ^ .,. , "Subroutine call but no subroutine specified")) 

; Look fop multiple demands on NAF, Note that skipping can be done 

: to .+1 If necessary (NAF otherwise tied up) 

: 2!'*!"**^'^®^*=? ^^" always be done by duplicating the target at the 

next successive contpoT memory location. ^ 9 -i 
(let ((jump get code 'jump-sequence)) 
(trap get code 'trap-sequence)) 
disp (oet code 'di spatch-taole) ) 

i=i«^ •'"'^^**^^^ ^°^® *ar ith-tpap-dispatch-table))) 
tana jump tpap 



one 
ion 



rt) 
OP a dispatch table 
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icheck-conf I ict code 'jump-sequence ' tpap-eequence 
"Conflict for NAF")) 
land jump disp 

ichecK-conf i ict code ' iump-seauence 'dispatch- table 
"Conflict for NAF")) 
{and jump ari th 

Icheck-conf I ict code 'jump-sequence *ari th-tpsp-ditpatch-table 
"Conflict for NAF**)) 
(and trap disp 

(check-conflict code 'trap-sequence 'dispatch- table 
•Conflict for NAF")) 
(and trap ar i th 

(check-conflict code 'trap-sequence 'ari th-trap-dispatch-table 
"Conflict for KAF")) 
(and disp ari th 

(check-conflict code 'dispatch-tab fe * ari th-trap-dispatch-table 
"Conflict for NAF"n 
(and (get! code ' (skip- true-sequence skip-fa I se-sequence)) 

(get I code ' (return-true-sequence return-false-? equence return-skip)) 
(check-toses "Trying to do two different kinds of skipping at the same time")) 
land (get code next-sequence) ;Normai successor 

(or (get code 'skip-true-sequence) jSkip successor 

(get code 'skip-fai se-sequence) ) 
(not Ifieldp code sequencer *pushj)) ;Skipping into a subroutine! 
(check-loses "Can't handle both a normal successor and a skip successor"}))) 



F:>lmach>ucode>FAICE-ARRAY.LISP.14 

; -*- node:Li8p; Base: 8; Lowercase: yes -»- 



(def var ft'Tay-tupe-table , ,, , «?"^C'S? a^« f^yP« type-code dispatch- 
M art-lb 0} (art-2b 1 1) (art-4b 2 2) (art-8b 3 3) (ar t-16b 4 4) 
(art-string 13 3) (art-fat-string 14 4) 



code) 



(art-q 5 Bj (art-q-iist £ 5) 
(art-boolean 18 19))) 

;This only aakes leader I ess 1-0 arraus (arrays of the first kind! 
(defun fake-array (memioc type sire &3ux type- info) 
(or (sctq type- info (assq type array- type- table)) 

(error |undefined array type! tupe)) 
(aset (set-cdr (set-type (dpb Ithird'type-info) 2B84 

(dpb (second type-info) 2204 
size)) 
dtp-header- i) 
1) 
•main-meooru* mem toe) 
(loop for i from fl belou size 

do (aset (set-type dtp-fix) »ma i n-memory« U memioc i 1))) 
(•et-type memioc dtp-array)) 

?nake arrays of the second kind (short ID with leader) 

(defun fake-array-with- leader (memtoc type size leader-size &aux type-info) 
(or tsetq tupe-tnfo (assq type array-type-table)) 

(error (undefined array type] type)) 
(aset (set-cdr (set-type (dpb 10 2BC4 

(dpb (second type- info) 2204 
(dpb leader-size 140S 
•ize))) 
dtp-header- i) 

•tmain-memory* memioc) 
(let (doc memlocH 

(loop repeat leader-size do (aset *ni l« snain-memory* (setq loc (1+ loc)))) 
(loop for 1 from 8 below size 

do (aset (set-type dtp-fix) «Bain-memory» (+ loc i 1)))) 
(»et-type memioc dtp-array)) 

(defun pa (array) 

(let ((head (aref jwnain-memory* (pointer-field array)))) 
(cond ((and (data- type? head dtp-header-i) 
(cdr-code? head D) 
(let ((disp (Idb 2604 head)) 
(type (Idb 2204 head)) 
(long- length (Idb 0322 head)) 
(teader- length (Idb 1408 head)) 
(short-length (Idb 0814 head))) 
(format t "-i^rray dispatch «*0, type MD " disp type) 
(loop for (tp tc dc) in array-type-tab ie 

when (- tc type) do (format t " (^vA) " tp) 
and unless (or (« disp 10) (• dc dispT) 

^ ,* . ^?^.^*°'"'"3* * "(disp should be -^) " dc) ) 
(cond ((< disp 10) 

(format t "size-*0^t" long-length) 
(loop for i from beiow Tong-Tength 
do (format t " (*0) " if 

(pq (aref «main-memory* (+ (pointer-field array) i 1))) 
(terpri))) 
((i> disp 10) 

nS««^LI ?'«a=^e'--»i2«— Ot array-si ze.-0-t- leader- length ehort- length) 
(loop for I from below leader- length ^ 
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do (format t - i-^J - iJ 

(pq (aref «aa i n-»eaory« (+ (pointer-field array) i 1))) 
(terprt)) 
(loop for i from belou short-length 
do (format t " (-^) " i) 
(pq (aref «niain-»iemory« 

(+ (pointer-field array) 1 leader-length 1))} 
(terpri))) 
(t (format t "[Bonus disp codel^X") ) ) ) ) 
(t (format t "••^ad array header"))))) 



(defunct ion aref 1188 (2) 
(push- local arg 8) 
(ar-1-loca! arg 1) 
(return-stack) ) 

(defunction aset 1118 (3) 
(push-local arg 8) 
(push- local arg 1) 
(aa-l-iocal arg 2) 
; (return-local arq 8) 
(push- 1 oca I arg 8) 
(return-stack) 
) 

; array-register test 

; (search-array value array fr 

;ara4 is the inaex offset, ar 



(defunction search-array 1128 
(push-iumed 8) 
(push-local arg 1) 
(push-local arg 2) 

(push- 1 oca I arg 3) 
(setup-ld-array-froffl-to) 
(pop-local arg 4? 
;ne3d of loop 
(push-local arg 11.) 
(push-local arg 18, ) 
(branch-greater-or-equai 7) 
(fast-aref-nopop arg S) 
(push- 1 oca I arg 8) 
(branch-eci 2) 
(add-ifflmeu 1) 
(branch -S) 
;Here if found 
(subtract-local arg 4) 
(return-stack) 
;Here if not found 
(push-i»med -1) 
(return-stack)) 



om to) 

g5-ie are array^regts ter, argil is subscript 



(4) 

:/4/ Make epaca for index offset 
i/5/ Open up the array 

/?/ 

;/8-12/ 
;/ll/ Save index offset 

tGet subscript 
;Comp3re against *to' 
;Branch if loop finished 
;Fetch from array 
;Comp3rB against value 
:Escape if found 
; Advance subscript 
;Loop core 

;Return unoffset subscript 
;NIL not addressible yet! 



(defunction array-leader 1158 (2) 
(array-leader) 
(return-stack)) 

(defunction store-array- leader 1168 (3) 

(push-local arg 8) 

(push-local arg 1) 

(push-local arg 2) 

(store-array- leader) 

; (return-local arg 8) 

(push- local arg 81 

(return-st ack)) 
; -»- floderLisp: Base:8; Lowercaserges -«- 

; Load up alt the files of the sinulated Microcode 

(defun loadup (f i le) 

(let ((truenaac (probef (setq file (mBrgef file ' (« fasi)))))) 
( terpr i ) 

(cond ((null truename) 
ipr inc file) 



(princ *| not found for loading. |)) 
(t ipr inc ' I Loading | ) 
(pr inc truename/ 



(pr inc 

(load fi le)}))) 



( loadup* sim) 

( loadup* uu) 

( loadup'ul ) 

(loadup'check) 

( )oadup*ua) 

( loadup* basic) 

( loadup' branch) 

( loadup'predicate) 

(loadup'funcal I) 

(loadup* funcal ID 

(loadup* funcal 12) 

(loadup' stack-buffer) 

(loaduD*3rrag) 
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((oadup*mut tlply) 
doadup' division) 
(loadup* tubpr (b) 
(ioadup'syn) 

;Load up coBtpited Lisp code files 

(loadup Mact/.slffl} 
Ctoadup * fake-array/. t isp} 

;;; -«- hoderLISP; Package7iirCR0; Base; 8 -«- 
;;; (c) Copyright 1SS2» SytnPotict, Inc. 

j;; riAkTE-SYSTEn aids for »(crocomp» ler 

(C^VAR *rUCHINE-VERSION«) tOne of Sltl, PROTO, TMC, IFU 

;Set this at top-Ieve! to uhat you uant before doing 
; incremental compilations. 



(DEFUr>l Sin-FASLOAD-l (UNFILE) 
(SI:FASL0AD-1 INFILE)) 

(DEFUN Sin-COnPILE-FILE-l (INFILE OUTFILE) 
(LET ((«nACHir€ -VERSION* 'SIH)) 

ISlxCOflPILE-FILE-l INFILE OUTFILE))) 

(DEFUN PROTO-FASLOAD-1 (INFILE) 
(SI:FASL0AD-1 INFILE)) 

(DEFUN PROTO-COriPILE-FILE-l (INFILE OUTFILE) 
(LET ((^HACHINE-VERSION* 'PROTO)) 
(SI:COnPILE-FILE-l INFILE OUTFILE) ) ) 

(DEFLW TnC-FASLOAD-1 (INFILE) 
(S1:FASL0A0-1 INFILE)) 

(DEFUN TnC-COnPILE-FILE-1 (INFILE OUTFILE) 
(LET ((^MACHINE-VERSION* 'TnO) 

(SlrCOnPILE-FlLE-l INFILE OUTFILE))) 

(DEFUN TnC5-FASL0AD-l (INFILE) 
(SI:FASL0A0-1 INFILE)) 

(DEFUN TnCB-COnPILE-FILE-i (FNFILE OUTFILE) 
(LET ((«nACHIN£-VERSION* 'THCS)) 

(SI:COnPILE-FlL£-l INFILE OUTFILE))) 

(DEFUN IFU-FASLOAD-1 (INFILE) 
(SI:FASL0A0-1 INFILE)) 

(DEFUN IFU-COnPILE-FILE-1 (INFILE OUTFILE) 
(LET ((^MACHINE -VERSION* MFU)) 

(Sl:COriPILE-FILE-l ItriLE OUTFILE))) 



;-«- HoderLISP; Package:USER; BaseVie -»- 

*n (EVAL-UHEN (EVAL LOAD COMPILE) (SETQ BASE 10. IBASE 18.)) 

(DEFVAR «EXPAND-ALIST* HIU tAUst of variables and forms bound to 

(DEFVAR »FIELD-DEFINITIONS* NIL> ;A/^st for field pseudo-op 

:Proaram»ing. 

;The*PAL looks like a 512x4 PROH. An Intact fuse is a 8 and a blown 

;fuse is a 1. Ue need a wap from pin numbers and assertion levels to 

; input nuBOers, a map fron product term nu:nbers to output pin nuabers 

;which they feed (or OEsl » and the map from input And product tertn to 

;uord and bit in the "PROfl". Also for the smaller PRoRs we need the 

; phantoa fuse pattern uhich fills in the unused locations in the 

; 512x4 array. 

sNote how they managed to uin. If you blow no fuses in a product term, 

;.t does not contribute to its OR/NOR. If you blow no fuses in a product 

;ter» that drives an OE, the output is turned off. 

X^HlWCmDir^^ COrC-fJAn^r"'"'*'"'" *"' ' '*^ *«P" definition 
/K^mcnc en ^ ! Symbol which is the nane of the PAL type 
n(;;b30?ln^D?F:,c kin . ^Number of words in pseudo PROM "^ 
Hirn -nlV'^fp in 1 't'?^ of output pins which are NW rather than OR 
LOU TNPnT MAP wn^ 'a" '^J 1''°'" ^i" """*'='^ ^° input-number for H 
b frPuVc '#7 "^*-^ 'fl"*'®^ ^':°'? P'" number to input-number for L 
PRnmrT MADi •5:'"?^*^ ?^ '"P"* columns in array 
(PRODUCT-nAP) ;A-frst from output/register pin number to 
; list of product ter»s? each product 
; term ts represented by a list of row number and 
; bit number. The fuses for this product term are 
; that bit of the PROH words addressed by input number 
! for fuse + (* row-numtier n-inputs). The product 
; terms ar^ ORed or NORed together of course 
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(OE-PRODUCT-nAF NIL) sSams for 0£ ppcduct teras (always asserted-high) 

(PHAMTCn-PU3E-R0UTINE NIL) ;Subroutine to initialize the array 

(REGISTERED-PI MS NIL) ;List of output pins uhich are pcgistered 

) ; • ..more later,.. 



(PUTPROP 



•PAL1GL8 
(HAKE-PALDEF 



INVERTED-PINS 
HIGH-INPUT-n/J= 



LOU- INPUT-HAP 



PRODL^CT-PIAP '((19 
(IS 
(17 
(16 
(15 
(14 
(13 
(12 

OE-PRODUCT-nAP 



NAHE 'PALIBLS 



•PALDEF) 



(12 13 14 15 16 17 15 19) 
' ((2 8) (3 4) /4 S) (5 12) (6 15) (7 
(9 28) (11 36) (13 25) (14 22) (15 
(17 10) (IS 6) (1 2)) 
((2 1) (3 5) (4 9) (5 13) (6 17) (7 
(9 29) (11 31) (13 27) (14 23) (15 
(17 11) (IS 7) (1 3)) 
(2 8) (3 8) (4 
(2 1) (3 1) (4 
(2 2) (3 2) (4 
(2 3) (3 3) (4 
(10 8) (11 8) 
(18 1) (11 
(18 2) (11 
(18 3) (11 
(18 (8 
(14 (8 



28) 
18) 



(8 24) 
(15 14) 



21) 

19) 



(8 25) 
(IS 15) 



(1 8) 

(1 1) 

(1 2) 

(1 3) 

(9 8) 

(9 1) 



(9 
(9 



((19 
(15 



2) 
3) 
(8 8)) 
(8 8)} 



1) 

2) 

3) 

D) 

D) 



8) 

1) 

2) 

3) 
C12 
(12 
(12 
(12 

(17 

(13 



(5 8) 
(5 1) 
(5 2) 
(5 3) 
8) 
1) 
2) 
3) 



(6 

(G 
(6 
(5 
(13 8) 
(13 1) 
(13 2) 
(13 3) 



(8 2)) 
(8 2)) 



(16. 
(12 



(7 

(7 

(7 

(7 
(14 8) 
(14 1) 
(14 2) 
(14 3) 



8)) 
D) 
2)) 
3)) 



(15 
(15 



8)) 
D) 



(8 3)) 
(8 3)))) 



(15 2)) 
(15 3))} 



(PUTPROP *PAL16R8 

(HAKE-PALDEF NAHE 'FALIGRS 
INVERTED-PINS '(12 13 14 15 16 17 18 19) 
REGISTERED-PINS M12 13 14 15 16 17 18 19) 

HIGH-INPUT-HAP '((2 0) (3 4) (4 8) (5 12) IB 16) (7 20) (8 24) 
(9 281 (12 381 (13 26) (14 22) (15 18) (16 14) 
(17 18) (18 S> (13 2)) 
LOU-If^T-nAP -((2 1) 13 S) (4 3) (5 13) (6 17) (7 21) (8 25) 
(3 29> (12 31) (13 27) (14 23) (15 19) (16 15) 
(17 11) (18 7) (19 3)) 



PRODUCT-HAP 

M(19 (8 8) (1 8) (2 8) (3 8) (4 0) 

(18 (8 1) (1 1) (2 1) (3 1) (4 1) 

(17 (8 2) (1 2) (2 2) (3 2) (4 2) 

(16 (8 3) (1 3) (2 3) (3 3) (4 3) 

(15 (8 8) (9 0) (18 8) (11 8) (12 8) 

(14 (8 1) (9 1) (18 1) (11 1) (12 1) 

(13 (8 2) (9 2) (18 2) (11 2) (12 2) 

(12 (8 3) (3 3) (18 3) (11 3) (12 3) 
•PALDEF) 

(PUTPROP 'FALIGRB 

(HAKE -PALDEF NAHE 
INVERTED-PINS * 
REGISTERED-PINS 
HIGH-INPUT-HAP 



(5 8) (6 0) (7 8)) 

(5 1) (6 1) (7 D) 

(5 2) (6 2) (7 2)) 

(5 3) (6 3) (7 3)) 

(13 8) (14 8) (15 8)) 
(13 1) (14 1) (15 D) 
(13 2) (14 2) (15 2)) 
(13 3) (14 3) (15 3)))) 



LOU- INPUT-HAP 



PRODUCT-HAP 

M(19 (1 0) 

(18 (8 1) 

(17 (8 2) 

(16 (8 3) 

(IS (8 8) 

(14 (8 1) 

(13 (8 2) 

(12 (9 3) 

OE-PRODUCT-HAP ' 
•PALDEF J 



•PAL16R6 

(12 13 14 15 15 17 18 19) 
* (13 14 15 16 17 18) 
•((2 8) (3 4) (4 8) (5 12) (5 16) (7 23) (8 24) 
(9 28) (12 30) (13 26) (14 22) (15 18) (16 14) 
(17 10) (18 6) (19 2)) 
{(2 1) (3 5) (4 9) (5 13) (6 17) (7 21) (8 25) 

[h'lWM^W 111 ill ^''''^ ^'^''^ '^^15' 



(3 8) (4 8) (5 8) 
(2 1) (3 1) (4 1) 
(2 2) (3 2) (4 2) 
(2 3) (3 3) (4 3) 
(18 8) (11 8) (1? 



(2 8) 
(1 1) 

(1 2) 

(1 3) 

(9 0) 

(S 1) (18 1) (11 1) (12 1) 

(9 2) (10 2) (11 2) (12 2) 

(10 3) (11 3) (12 3) (13 3> 

((19 (8 8)) (12 (8 3)))) 



(6 0) (7 0)) 

(5 1) (6 1) (7 D) 

(5 2) (6 2) (7 2)) 

(5 3) (6 3) (7 3)) 

0) (13 0) (14 0) (15 8)) 



(13 1) (14 1) (15 D) 
(13 2) (14 2) (15 2)) 
(14 3) (15 2)}) 



(PUTPROP 'PALIBR^ 

(HAKE -PALDEF NAHE 
INVERTED-PINS ' 
REGISTERED-PINS 
HIGH- INPUT -HAP 



LOU- INPUT-HAP 



PRODUCT-HAP 

• ((19 (1 8) 
(18 (1 1) 
(17 (8 2) 
(16 (8 3) 
(15 (S 8) 
'^ (8 1) 
(3 2) 
(9 3) 



•PALieR4 

(12 13 14 15 16 17 18 19) 
M14 15 16 17) 
•((2 8) (3 4) (4 8) (5 12) (6 16) (7 20) (8 24) 
(9 28) (12 30) (13 26) (14 22) (15 IS) (16 14) 
(17 18) (IS 6) (19 2)) 
((2 1) (3 5) (4 9) (5 13) (6 17) (7 21) (8 25) 
(9 29) (12 31) (13 27) (14 23) (15 19) (15 15) 
(17 11) (IS 7) (19 3)) 



(14 

(13 

(12 

OE-PRODUCT-HAP 
•PALDEF) 



(2 8) (3 8) (4 8) (5 8) (6 0) (7 0)) 

(2 1) (3 1) (4 1) (5 1) (6 1) (7 D) 

(1 2) (2 2) (3 2) (4 2) (5 2) (6 2) (7 2)) 

(1 3) (2 3) (3 3) (4 3) (5 3) (6 3) (7 3)) 

(9 0) (10 8) (11 8) (12 8) (13 8) (14 8) (15 8)) 

(9 1) (18 1) (11 1) (12 1) (13 1) (14 1) (15 D) 

(18 2) (11 2) (12 2) (13 2) (14 2) (15 2)) 



(10 3) (11 3) (12 3) (13 3) (14 3) (15 3))) 
M(19 (0 8)) (18 (8 D) (13 (8 2)) (12 (8 3)))) 
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(PUTPROP 'PALIBHS 

(nAk'E-PALDEF NAHE 'PALieHS 
HIGH- INPUT -HAP '((2 0) (3 4) (4 8) (5 12) (S 16) (7 28) (8 24) 

(9 28) (11 38) (1 2)) 
LOU-H^PUT-HAP M(2 D (3 5) (4 9) (5 13) (S 17) (7 21) (8 25) 
(9 29) (11 31) (1 3)) 



PRODUCT-HAP M{19 (8 8) 


(1 8)) 


(18 (3 1) 


(1 D) 


(17 (8 2) 


(1 2)) 


(IS (8 3) 


(1 3)) 


(15 (8 8) 


(9 0)) 


(14 (8 1) 


(9 D) 


(13 (8 2) 


(9 2)) 


il2 (8 3) 


(9 3))) 



PHANTOn-FUSc -ROUTINE 'PALlCHS-PHANTOn-FUSE) 
•PALDEF) 

(DEFUN PAL18H8-PHANT0n-FUSE (ARRAY) 

;; Fill columns corresponding to unused inputs with l*s 
(LOOP FOR COLUriN IN ' (6 7 18 11 14 15 18 19 22 23 25 27) 
DO (LOOP FOR ROU FROH TO 15 

DO (ASET 15 ARRAY (+ (» ROU 32) COLUHN) ) ) ) 
:; Fill unused rows with (all rows except 8, 1, 8, 9) 
(LOOP FOR ROU FROn TO 15 . x, o. ^ 

UNLESS (MEiiBER RDU ' (0 1 8 9)) 

00 (LOOP FOR COLUnN FROH BELOU 32 

DO (ASET 8 ARRAY (+ (« RDU 32) COLUHN) ) ) ) } 

(PUTPROP •PAL20L10 

(HAKE-PALDEF NAHE 'PAL20U10 
N-INPUTS 40. 

INVERTED-PINS M14 15 IB 17 18 19 20 21 22 23) 
HIGH.ir^UT-nAP '((2 0) (3 4) (4 8) (5 12) (6 16) (7 20) (8 24) 
(9 28) (10 32) (11 35) (13 38) (15 34) 
(16 30) (17 25) (18 22) (19 18) (20 14) 
(21 10) (22 G> (1 2)} 
LOU-INPUT-MAP '((2 1) (3 5) (4 9) (5 13) (B 17) (7 21) (8 25) 
(9 29) (10 22) 111 37) (13 29) (15 35) 
as 31) (17 27) (18 23) (19 19) (20 15) 
(21 11) (22 7) (1 3)) 

•PALDEF) 

; For the 20X register series, the lauout is similar except that 

; the 4 product terms for an output are OR'ed together in pairs 

; then XOR'ed toqether and the result is the complement of the 

; output. 

;Specials for encodi f icat ion 

(DEFVAR «ARRAY») 
(DEFVAR «IPINS«) 
(DEFVAR «PALDEF*} 
(DEFVAR «VAR*) 
(DEFVAR «TERnS*) 

:DEFPAL expands into a PAL -EQUATIONS property for checking, 
:p(us stores an arrag into the value of the symbol, where 
;the FROn programming software wants it. 

MDEFPAL-l '.NATIE '.TYPE *, CLAUSES)) 

IDEFUN DEFPAL-l (NAnS TYPE CLALSES 

4AUX [PIN'S REAL-IPINS PALDEF RPINS OUTPUTS 

(OR (SETQ PALDEF <GEf fv'p^°'^k[EI^)f' ^°-°''''^'^^°'^^* ''' ^^'^^^ 

(FERROR NIL "-.S undefined PAL type* TYPE)) 
:Par«e the specifications 
(DOLIST (CLAUSE CLAUSES) 
(SELECTQ (FIRST CLAUSE) 
(iPIN 
(LET ((SIG (THIRD CLAUSE)) 

(PIN (SECOND CLAUSE))) 
(LET ((HINPjJT (CADR (ASSOC PIN (PALDEF^IGH- INPUT -P1AP PALDEF)))) 
^ (LINPUT (CADR (ASSOC PN (PALDEF-LOU-INPUT-riAP PALDEF) ) )) 
(OR (AND HINPUT LINPUT) (FERROR NIL "Pin io is not an input- PIN)) 
<IP {^3^3 PIN (PALDEF.REGISTERED-PINS PALDEF)) ^ ^"'^ 
,,- )E£"^y5.,Kl'" I^*" ^ is a registered output; don't use IPIN" PIN)) 

i^Ss^'^Lii?^iis sva^ef vik^u^ ??Nyi^^ ^^^^^ ^'^"^ ""^"" ' 

((OPI^^^^N?'^ '^^-'""^^''^^ 
(LET ((SIG (THIRD CLAUSE)) 

(PIN (SECa^D CLAUSE))) 
(IF (EG (FIRST CLAUSE) 'RPIN) 

(LET ({REG-INPUT (INTERN (FORHAT NIL "f€XT--.A" (THIRD CLAUSE) )) >) 
(PUSH (CONS SIG REG-INPUT) RPINS)iSet up rena^ng for f«db^^^ 
(OR (^r|ER PIN (PALDEF-REGISTERE6-PINS PALDEFJr ^««^^ach 

(FERROR NIL "Pin *vO is not a reqistered output: don*t use RPIN" PIN)) 
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(LET ((HINPUT (CADR (ASSOC PIN (PALDEF-HIGH-INPUT-nAP PALDEF) ) ) ) 
(LINPUT (CADR (ASSOC PIN CPALDEF-LOU-INPUT-nAP PAtDEF) ) } ) } 
(OR (AND HINPUT LINPUT) , ^, _ 

(FERRDR NIL "Pin ^ is not an input (needed for feedback)" PIN)) 
(IF (EQ (FOURTH CLAUSE) 'D (PSETQ HINPUT LINPUT LIfPUT HINPUT)) 
(PUSH (LIST SIG HINPUT LINPUT) IPINS)) ;This is feedback 
(SETQ SIG REG-INPUT)) rThis is what comes out of the array 

(IF (HEnSER PIN fPALDEF -REGISTERED-PINS PALDEF)) 

(FERROR NIL "Pin ^ is a registered output; don't use OPIN" PIN))) 
(OR (HATCH-ASSERT ION-LEVEL? PALDEF PIN (FOURTH CLAUSE)) 
(LET ((NEG-SIG (INTERN (FORflAT NIL "NOT-.A" SIG)))) 
(PLtSH (CONS NEG-SIG '(NOT ,SIG)} «EXPANO-ALIST*) 

(SETQ SIG NEG-SIG))) :Thi8 is uhat realty comes out of array 

(PUSH (LIST SIG PIN) OUTPUTS))) 
(OE (PUSH (LIST (THIRD CLAUSE) (SECOND CLAUSE) 'OE) 

OUTPUTS)) ; Always asserted hi ah 

(SETQ (PUSH (CONS (OR (CDR (ASSQ (SECOND CLAUSE) RPINS)) (SECOND CLAUSE)) 
(THIRD CLAUSE)) 
«EXPAND-ALIST*)) 
(FIELD (PUSH (COR CLAUSE) *F I ELD-DEFINITIONS*)) 

(OTHERUISE (FERROR NIL "-S unknown DEFPAL clause* (FIRST CLAUSE))))) 
(LOOP FDR (SIG PIN OE) IN OUTPUTS 

U^^ILESS (ASSOC PIN (IF OE (PALDEF-OE-PROOUCT-flAP PALDEF) (RALDEF-PRDOUCT-riAP PALDEF))) 
DO (FERROR NIL •*Ptn *0 ts not defined in the output*: ['-; -enable^! table" PIN OE) ) 
5 Turn on anu outputs whose OEs are not specif iedl 
(LOOP FOR (PIN) IN (PALDEF-OE-PRODUCT-nAP PALDEF) 
UHEN (LOOP FOR (IGNORE OPIN OE) IN OUTPUTS 

THEREIS (AND (• OPIN PIN) (NOT OE))) 
UHEN (LOOP FOR (IGNORE OPIN OE) IN OUTPUTS 
NEVER (AND (- OPIN PIN) OE)) 
DO (LET ((NAHE INTERN (FORriAT NIL "PIN-^-OE" PIN)))) 
(PUSH (LIST NAHE PIN 'OE) OUTPUTS) 
(PUSH (CONS NAHE T) «£XPAf^D-ALIST«)) ) 
;Do the boolean algebra to get a sum, of products for each array output 
(SETQ EQS (LOOP FOR (VAR) IN OUTPUTS 
COLLECT VAR 

COLLECT (EXPANO-AND-SinPLlFY VAR))) 
(PUTPPOP NAME (CONS 'SETQ EQS) 'PAL-EQUATIONS) 
;Check that all inputs are used 
(LOOP FOR (IGNORE EXP) ON EQS BY 'CODR 

DO (SETQ REAL-IPINS IDELETE-USED- INPUTS EXP RE AL-I PINS) ) ) 
(IF REAL-IPINS 

(FGRHAT T "-w^Inputs not U8eds*( -^A-v) • REAL-IPINS)) 
jMake the array and initialise it to the initial fuse states (all intact now) 
(SETQ ARRAY (flAKE-ARRAY (PALDEF-N-UORDS PALDEF) ) ) 
(FILLARRAY ARRAY ' (8)) 
(IF (PALDEt^-PHANTOn-FUSE-ROUTlNE PALDEF) 

(FUr^CALL (PALDEF-FHANTOn-FUBE-ROUTINE PALDEF) ARRAY)) 
;Go over the outputs and store their fuses into the array 

(LOOP WITH «ARRAY« - ARRAY AND «IPINS* - IPINS At^ tfALDEF* « PALDEF 
FOR («VAR« PIN OE) IN OUTPUTS AND (IGNORE EXP) 0\i EQS BY 'CDOR 
AS HAP . (IF OE (PALDEF-OE-PRODUCT-nAP PALDEF) (PALOEF-PRODUCT-nAP PALDEF)) 
AS *TERnS* - (CDR (ASSOC PIN HAP)) 
DO (ENCODIFY EXP)) 

(SET NAHE ARRAY) 

(PUTPROP NAHE TYPE ^PAL-TYPE) 

NAME) 

(DEFUN DELETE-USED-INPUTS i£XP SIGS) 
(CONO ((ATOn EXP) (DELQ E>P SIGS)) 

(T (LOOP FOR EXFl IN (CDR EXP) 

DO (SETQ SIGS (DELETE-USED-INPUTS EXPl SIGS))) 
SIGS))) 

(DEFUr^ HATCH-ASSERT I DN-LEVEL? (PALDEF PIN-NUTIBER LEVEL) 
(EQ (NOT (EQ LEVEL 'D) 

(NOT (MEnQ PIN-NUHBER (PALDEF- I NVERTED-P INS PALDEF))))) 

;Blou ail fuses exceot the ones sped fied 
(DEFUN BLOU-PRODUCT-TERn (INPUT-NUrtBER-LiST) 
(LET ((TERn (POP «TE^S*)}) 

(OR TERM (FERRCR NIL "Not encugh nroduct terms to do -S" »YAR») ) 
(LOOP UITH TFRn-BASE - (» ^CAR TERn\ IP ALDEF-N- INPUTS «PALDEF*) ) 
UITH BITHASK - (LSH 1 (CADR TERn)) 
FOR INP FROM BELOU (PALDEF-N- INPUTS «PALDEF*} 
UNLESS (nEnSER INP INPUT-NUHBER-LIST) 

00 (ASET (LOGIOR (AREF ^cARRAY* (+ TERH-BASE INP)) BITttASK) 
«ARRAY» (+ TERn-BASE INP))))) 

(DEFUN ENCODIFY i£XP AAUX TEn) 
(COND ((EQ EXP NIL) 

;B!ow no fuses 

NIL) 
((EQ EXP T) 

;Blow all fuses in one product ter» 

(BLOU-PRODUCT-TERn NIL)) 
((SETQ TEn (ASSQ EXP «IPINS*)) 

(DLOU-PRODUCT-TERn (LIST (CADR TEH)))) 
((ATOn EXP) 

(FERROR NIL "^S undefined variable in expression for *S" EXP »VAR«)) 
((Ar;D (EQ (CAR EXP) 'NOT) 
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(SETQ TEM (ASSQ (CADR EXP) «IPINS«)}} 
(BLOU-FHGD'XT-TERn (LIST (CADDR TEH)))) 
((EQ (CAR EXPJ 'AND) (E.NCOOIFY-Ar.'D (COR EXP) ) ) 
((EQ (CAR EXP) 'OR) ini^PC r.EUZOUlfi (CDR EXP))) 
{T {FERROR NIL "-^S unrecognizabte expression for ^S" EXP «VAR*) ) ) ) 

iDEfm E^JCODIFY-AKD .(FACTORS &AUX TEH) 
(BLCul-PRGDXT-TERn 

(LOOP FOR FACTOR IN FACTORS 

(CDNO ((SETQ TEH (ASSQ FACTOR «IPINS«)) (CAOR TEn) } 
((Ar;0 (NOT (ATCn FACTOR)) 

(EQ (CAR FACTOR) 'NOT) 
(SETQ TEM (ASSa (CADR FACTOR) «IPINS*))) 
(CADDR TEM)) 
(T (FERROR NIL "^S undefined in expression for *S' 
FACTOR *VAR*)})))} 

;Pr»nt out in format aitnilar to ntll nanuai 
;X for (connected fuse), blank for 1 (bloun fuss) 
(DEFUN PRINT-PAL -ARRAY (ARRAY) 
(TERPRI) 
(PRINC - .") 

(LOOP FOR COLUriN FROn e EELOU 32. BY 4 
DO (FORHAT T "^«<^->." COLUHN)) 
(LOOP FOR ROU FROn 9 BELDu' 16. 
DO (FORriAT T --.X-.20 "" BCU> 

(LOOP FOR BIT m 8 THEN (LSH BIT -1) UNTIL (2ER0P BIT) 
DO (TERPRI) (PR INC " -**) 

(LOOP FOR COLUHN FRGn 8 EELOU 32. 
UNLESS iZEnB? COLUHN) UHEfJ (- (\ COLUMN A) 8) DO (TYO tf/.) 
DO (TVO (IF (BIT-TEST BIT (AREF ARRAY (+ (» ROU 32.) COLUHN) ) ) 
tf\SP U/X))) 
(PRINC --")))) 

:nake a nane. PAL-CHECK file 
(DEFUN flAKE-CHECK-FILE (NAr£) 

(LET ((FILE (OPEN (FORHAT NIL "-A.PAL-CHECK" NAHE) *PRINT)}) 
(LET m ((OUTFILES (LIST FILE)) C^ T) C^ T) ) 
ffCi ( (STAND-ARD-OUTPUT FILE)) 
itm SPRINTER UQ GRIND-TOP-LEVEL (GET NAME 'PAL-ECUATIONS) ) 
(TERPRI) 

(PRINT-PAL-ARRAY (SYHEYAL NAHE) ) ) 
(CLOSE FILE))) 
jExpansion phase. 

;This timpJt^ expands Macros and plugs in vafues of "variables" 
;No tiBtpt i f icat ion is done. 
;You then aay call SIHPLIFY on the result. 

;Thts is the "cntrg" 

jxpanci into iiacro calls, this It 

[)' 



;So that macros may expand into macro calls, this loops until done 
(DEFUN EXPAND (FORfl ^OPTIONAL NO-COND dAUX TEH FORHl) 



(LOOP DOING 

(COND ((ATOn FORH) 

(IF (SETQ TEH (ASSQ FORH «EXPAf^-ALIST«) ) 
(SETQ FORn (COR TEH) ) 
(RETURN FORn))) 
if AND NO-COND (EQ (CAR FORn ) 'COND)) (RETURN FORH) ) 
((SETQ TEn (ASSQ (CAR FORH) 

•((FIELD . EXPANO-FIELD) (COfd . EXPANO-COND) 
(IF . EXP AND-IF> 

(NOT . EXPAND-NOT) (AND . EXPAND-AND) 
(OR . EXPANO-OR) (XOR . EXPAr;0-XOR) 
rr^^rn .ro««, ,^..^ (UIRED-XOR • EXPANO-UIRED-XOR) ) ) ) 
(SETQ FORHl (FUNCALL (CDR TEM) (CDR FORn))) 
(IF (EQUAL FORm FORH) (RETURN FORH) 
(SETQ FORn FORni))} 
(T (FERROR NIL "-^S unrecognized - EXPAhO" FORM))))) 

s (FIELD signal-n signai-n-l ... tignal-fi (vafue value..,)) 
tor (FIELD fieldname (value vaiue,..)) 
(DEFUN EXPANO-FIELO (ARGSi 
(CONS 'OR 

(LOOP FOR VALUE IN (IF (LISTP (CAR (LAST ARCS))) (CAR (LAST ARCS)) 
(LAST ARCS)) 
WITH SIGNALS - (EXPAND-Fl ELD-SIGNALS CBUTLAST ARCS)) 
COLLECT (CONS 'AND 

(LOOP FOR SIGNAL IN SIGNALS 

FOR nAS< « (LSH 1 (1- (LENGTH SIGNALS))) 

THEN (LSH nAS< -1) 
UHEN (BIT-TEST MASK VALUE) 
COLLECT SIGNAL 
ELSE COLLECT MNOT .SIGNAL)))))) 

(DEFUN EXPANO-FIELD-SIGNALS (SIGS) 
(LOOP FOR SIG IN SIGS 

WHEN (CDR (ASSQ SIG »FIELD-DEFINITIONS«) ) APPEND IT 
ELSE COLLECT SIG)) 

:Note that the antecedents should not overlap, and if it drops off the end 
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; i t' s dont-care 

(DEFUN EKPAND-CONt) (ARCS) 

(CONS 'OR (LOOP FOR CLAUSE IN ARCS 

UHEN (EQ (CAR CLAUSE) T) 

(DEFUfj EXPA\*0-IF (ARCS) 

MOR (Ara .(FIRST ARCS) .(SECOND ARCS)) 

(AI4D (NOT , (FIRST ARCS) J .(THIRD ARCS)))) 

;XOR expands in terms of Af^iO and OR 
(DEFUN EXP Afd-XOR (ARCS) 
(COfJS 'OR (LOOP " 



FOR CODE FROn 8 BELOU (EXPT 2 (LENGTH ARCS) ) 

UHEN (ODD-PARITY CODE) 
COLLECT (CONS 'AND 

(LOOP FOR ARC 
COLLECT 



l^r-^SS FOR BIT - 1 THEN (* BIT 2) 

(IF (BIT-TEST BIT CODE) '(NOT .ARC) ARC)))))) 



(DEFUf^ ODD-PARITY (N) 

(LOOP FOR N - N THEN (// N 2) UNTIL 
U'HEN (ODDP N) DO (SETQ PA;?iTr 
FINALLY (RETURN PARlXy)}) 



ilEROP H) UITH PARITY 
(NOT PARITY)) 



NIL 



argument" (CONS 'NOT ARCS))) 



luTRPn^ynS^S^ '* present, it stays as UIRED-XOR in the expansion, 
tWIRED-XOR may only be used with PALs that have uired-in XOR capability. 

^(defun'eW^uJred-^^^ "^^^°-'°' '» "'^'^'^^ ^« "*S^*'"B ''« ^'^^^ •^3-«"^- 
(OR (. (LENGTH ARCS) 2) 

•KSI ^9'^,.S5!;^^®'8- "ove ^^^ inside of XDR. 

:NOT of CONO^moves inside. Note uetl that if CDNO drops off the end 

\DEPUUnxpluD%^^^^ ""' ''^^' "^^'^ •» *^« °"'W ^°- «' dont-care. 

(OR (- (LENGTH ARCS) 1) 

„^ tP^f^gOR NIL "-S NOT with other than 1 
(LET ((ARG (EXPAND (FIRST ARCS) T) ) ) 
(CCrJD ((ATOn ARG) '(NOT ^ARG)) 

({EQ (CAR ARG) 'NOt) (CADR ARG)) 
((EQ (CAR ARG) TCND) 
(CONS 'COND (LOOP FOR CLAUSE IN (CDR ARG) 

COLLECT (LIST (CAR CLAUSE) 
(EXPAr;0-NOT (CDR CLAUSE)))))) 

J^^9,»J,S^^ ^S^I.i'r^J^-^-^Of^^ • (UIRED-XOR (NOT .(CADR ARG)) . (CAODR ARG) ) ) 
(T (NOT ,ARG) ) I ) ) 

(C£FUN EXPAND-OR (ARCS) 

(CONS 'OR (HAPCAR ;;r' EXPAND ARCS))) 

(DEFUN EXPW>D-AND (ARCS) 

(CONS 'AND (riAPCAR #' EXPAND ARCS))) 
;Simpl i f (cation phase 

(DEFUN EXPAND-AND-SinPLIFY (FORH) 
(SinPLIFY (EXPATS FORH))) 



;Simp t i fu and get 

(OEfOn srnPLiFY (forh) 



into disjunctive normal form (with a possible top-level UIRED-XDR) 



(CONO ((ATOn FORH) FORn) 

((EQ (CAR FORM ) 'NOT) (SinPLlFY-NGT (CADR FORH) ) ) 

((EQ (CAR FORn ) 'AND) (SinPLIFY-AND (CDR FORn)) 
((EQ (CAR FORn) 'OR) (SIHPLIFY-OR (CDRFORH)) 
((EQ (CAR FORn ) 'UIRED-XOR) 

(f(FPRRnR^w?r^?^^^ f?F§ti9 ^Rgn!!..^SinPLIFy (THIRD FORH)))) 

(T (FhRRUR NIL "-^-S - at simplify??" FORM) ) ) ) 



; Various useful primitives 
(DEFUN LITERAL? iX) 

(OR (ATOn X) (A^4D (EQ (CAR X) 



•NOT) (ATDH (CADR X))))) 



(DEFUN OPPOSITES? fX Y) 

(OR (AND (NOT (ATOfl X)) (EQ (CAR X) 'NOT) (EQUAL (CADR X> Y) ) 
(AND (NOT (ATOn Y) ) (EQ (CAR Y) 'NOT) (EQUAL (CADR Y) X)))) 

:Canontcal ordering of literals. 

;NIL is less than T is less than other atoms, which 
"•sort alphabetically (only symbols allowed). 
;NgTs sort the same as their arguments. 
(DEFUN CANONICAL-LESSP (X Y) ''^S"'"^""^- 
(OR (ATOn X) (SETQ X (CADR X))) 
(OR (ATOn Y) (SETQ Y (CAOR Y))) 
(CONO ((NULL X) T) 

((NULL Y) NIL) 

((EQ X T) T) 

((EQ Y T) NIL) 

(T iffn ALPHALESSP ^ STRING-LESSP X Y)))) 
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(DcFUr>l Sinc'LIFY-NOT (ARC) 
(CONG {(EQ ARG NIL) T) 
((EQ ARG T) NIL) 
{(ATOM ARG) MNOT , ARG) ) 

((EQ (CAR ARG) 'NOT) (SinPLIFY (CADR ARG))) 
(T^^^^PTQ^ Rr^(ci^P^V^^^R^'"^^^'°^^ (HAPCAR Xf'SinPLIFY-NOT (CDRARG)))) 

(COND ((OR TlITERAL? ARG) {HEnQ (CAR ARG) MNOT AKD))) 
(SinPLlFY-NQT ARG)) 
((EQ (CAR ARG) 'OR) 

(SinPLIFY.A\'31 (HAPCAR r SltlPLlFY-NCT (COR ARG)))) 
(T (FERROR NIL "^S after 8 tmpi t f icat ion - SinPLIFY-NOT" 
ARG)})))) 

;0R whose arauments have not yet been simplified 
(DEFUN SIMPLIFY-OR (ARCS) "^ *^ ^ 

(CONO ((NULL ARCS) NIL) 

((NULL (COR ARCS)) (SirTPLIFY (CAR ARCS))) 

(T (SinPLIFY-ORl (HAPCAR <f'Sm?LlFY ARCS))))) 

^DEFUN^IinPLlFToR^^ (ARG3)"" •'"P'"'^'*^ ^^"^ »'«* "« ^« clobbered) 
(SETQ ARGS (DELQ NIL ARCS)) 
(com ((NULL ARGS) NIL) 

((NULL (COR ARGS)) (CAR ARGS) ) 
((HEriQ T ARGS) T) 
(T ;0R mergina 

(LOOP FOR ARG IN ARGS 

UNLESS (LITERAL? ARG) 
UHEN (EQ (CAR ARG) 'OR) 

DO (SETQ ARGS (NCONC (DELQ ARC ARGS) 

(CGPYLIST (COR ;*RG) ) ) ) 
ELSE UNLESS (EQ (CAR ARGi ^AND) 

DO (FERROR NIL ^S - garbage term in SinPLIFY-ORl" ARG)) 
;Reffove redundant terms (which must be conjuncts new) and also 
jjnerge terms which are the same except for a clash in one factor 
;Redundant terms cr identical or one is covered bu the other, 
(St TQ ARGS (REnOVE-REOUr;OA[;CIES ARGS)) 
(COND ((NULL ARGS) NIL) 

((NULL (CDR ARGS)) (CAR ARGS)) 
(T (CONS 'OR ARGS))))}) 

:Note: this is not as optimal as it could be, since it only optimizes pairwise 
;For instance, it won't optimise (or (and a b) (and a c) (and b -c) (and -b c)) 
I'D^o (or (and a b c) (and b -c) (and -b c)) 
(DEFUN REnOVE-REDUNDANCiES (TERMS) 
(LOOP UHILE 

(LOOP FOR (TERni , REST) ON TERMS THEREIS 
(LOOP FOR TERM? IN REST 

UJLESS (OR (LITERAL? TERMl) (LITERAL? TERM2)) 
ThcREIS 
(LCaP FDR (X . RESTl) ON (CDR TERMl) 
r.SP^iX •..5^ST2) ON (CDR TERM2) 
UNLESS (EOUAL X Y) 

WHEN (ANO (OPPQSITES? X Y) (EQUAL RESTl REST2)} 

DO (OR (EQ (CAR TERMl) 'AND) : paranoid 
(BREAK REnOVE-REDUNOAfJCES-BARF T)) 
(SETQ TERMS 

(CONS CriA<E-AND (DELQ X (CDR TERMl))) 

(DELQ TERMl (DELQ TERn2 TERMS)))) 
(RETURN T) ;Done with TERMl 
ELSE RETURN NIL) 
WHEN (OPPOSITES? TERMl TERM2) 

RETURN (SETQ TERMS (LIST T)) 
UHEN (COVERS? TERMl TERM2) 

RETURN (SETQ TERMS (DELQ TERM2 TERMS D) 
UHEN (COVERS? TERM2 TERMl) 

RETURN (SETQ TERMS (DELQ TERMl TERMS 1))))) 
TERMS) 

(DEFLEN MAKE -ANO (ARGS) 
(C0;4D ((NULL ARGS) T) 

((NULL (CDR ARGS)) (CAR ARGS)) 
(T (CONS 'AfJO ARCS)))) 

;Does one conjunct cover another 
(DEFUN COVERS? (X Y) 

(IF (LITERAL? X) (IF (LITERAL? YV (EGUAL X V) 
mEMBER X iCuB Y}>} 
(AND (NOT (LITERAL? Y)) 

(NOT (> (LENGTH X) (LENGTH Y) ) ) 
(LOOP FOR XX IN (CDR X) 

ALUAYS (MEnaER XX (CDR Y)))))) 
{Simplification of ANDs^ including distribution of AND over OR. 

I AND whose arguments have not yet been ttmptified 
(DEFUN SIMPLIFY-AND (ARGS) 
(COND ((NULL ARGS) T) 

((NULL (CDR ARGS) ) (SIMPLIFY (CAR ARGS))) 
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(T (SinPLIFY-ANDI (HAPCAR ^'SlflPLIFY ARCS) ) ) ) ) 

;ANO whose arauments have been simplified (and fist sau be clobbered) 
(DEFUN SinPLlFY-ANDl tARGS) 
(5ETQ ARCS (DELQ T ARGS)) 
(COND {(NULL ARGS) T) 

((NULL (CDR ARGS)) (CAR ARGS) ) 
((HEriQ NIL ARGS) NIL) 

(T (LOOP FOR ARG IN ARGS ?OR/AfC mergina 

UNLESS (LITERAL? ARG) * ^ 

UHEN (EQ (CAR ARG) 'AND) COLLECT ARG INTO ANDS 
^ ELSE UHEN (EQ (CAR ARG) *0R) COLLECT ARG INTO ORS 
FINALLY 
(RETURN 

iCmU (ANDS 

(DOLIST (X ANDS) (SETQ ARGS (DELQ X ARGS))) 
(DOLIST (X ANDS) (SETQ ARGS (f^ONC ARGS (COR X)))) 
(SinPLIFY-ANDl ARGS)) 
(ORS 
(DOLIST (X ORS) (SETQ ARGS (DELQ X ARGS))) 
(AND (SETQ ARGS (SinPLIFY-ANDl ARGS)) 
(SinPLIFY-ORl 
(DISTRIBUTE ORS (LIST ARGS))})) 

(SETQ ARGS (SORT ARGS )(^'CANONrCAL-L£S£P) ) 
(LOOP FOR (FIRST NEXT) ON ARGS 

m£H (OPPDSITES? FIRST NEXT) 

RETURN NIL 
UNLESS (EQUAL FIRST NEXT) 
^COLLECT FIRST INTO RESULT 
FINALLY 
(RETURN 

(C0I40 ((NULL RESULT) T) 

(UnJLL (CDR RESULT)) (CAR RESULT)) 
(T (CONS 'AND RESULT)))})))))))) 

:Distribute each of the OR cxpreesions in ORS over EXPS, which is the 
;cdr of an OR expression containing only conjuncts. Simplify at each 
IdEfSn 01STRIBUTr(§Rs'EXfi) *"^ '°''' combinatorial explosion. 
(IF (NULL ORS) EXP 

(SETQ EXP (SinPLlFY-ORl 

(LOOP FOR X IN (CDAR ORS) 

NCONC (LOOP FOR Y IN EXP 

UHEN (HERGE-CONJUNCTS X Y) 
(DISTRIBUTE (CDR ORS) COLLECT I T) )) , 

(IF (OR (ATOn EXP) (NOT (EQ (CAR EXP) 'OR))} 
(LIST EXP) 
(CDR EXP))))) 

(DEFUN rtERGE-CDNJUNCTS (X Y) 
(COf;0 {(EQ X NIL) NIL) 
{(EQ Y NIL) NIL) 
((EQ X T) Y) 
{(EQ Y T) X) 
((LITERAL? X) 
(COND ((NOT (LITERAL? Y) ) (ADD-TO-AND Y X T) ) 
((EQUAL X Y) X) 
((0FP05ITES? X Y) NIL) 
((CANONICAL-LESSP X Y) '(AND ,X ,Y)) 
^ , (T MA.NO ,Y ,X)))) 
((LITERAL? Y) (AfiO-tO-AND X Y TU 
(T (LOOP FOR YY IN (CDR Y) UITH COPYP - T 
AS NEUX - (ADD-T0-A;4D X YY COPVP) 
UNLESS (EQ NEUX X) 

DO (SETQ X KEUX COPYP NIL) 
UNTIL (NULL X)) 

;Given a canonical, sinjpiified conjunct, add one nore factor 
IID3 '"fi^urn a canonical, simplified ccniunct, 
(DEFUN AGD-TO-AND (AND f ACTOR COPYP) ^ 

(CDIO {{^ITEpAL? AND) (SETQ AND * {MiD ,AND) COPYP NIL)) 
IthU^tCAR AND) AND)) 

„ f^^r, iL'c^^^Qf^ NH- "^S - how did this get here? - ADD-TO-AND" AND))) 

"^EcT,*IP'^f^V. ^^^^^ ^A*'-^ f'ACTGR) 

nt I UK. , f J I L 

UHEN (GPF03ITES? (CADR TAIL) FACTOR) 
RETURN (SETQ AND NIL) 

U€N (CANONICAL -LE5SP FACTOR (CADR TAIL)) 

RETURN (IF COPYP (SETQ AND (COPYLIST AND) TAIL (NTHCOR I AND))) 
(RPLACO TAIL (CONS FACTOR (CDR TAIL)))) 
(COND ((NULL AND) NIL) 

((NULL (CDR Afd)) T) 

((NULL (CDOR AND)) (CADR AND)) 

(T AND))) 
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t;; -»- Hode:L)«p; Package; flicpo; Base: 8; Lowepcaeert -«- 
;;; <c) Copyright 1382» Sgnbotics. Inc. 

; Simulator of L-«achine ■icrocoda 

; This file contains the framework needed to run everything etse 

; This part gets loaded before the architecture definitions, SlflX is loaded later 



;tCludges 

<ff1 (dec fare (murzfed t)) 
Jttl (evat-hthen (load) 

(putprop • ioop-collect-init (get 'loop 'autoload) 'autoload)) 

1 Memories 

(bef const «aiatn-»e»ory-size« 40000) ;1BK: should be enough for angonel 
(defvar »main-me«ory« (make-array scmain-memory-size*) ) 

(defconst «a-memory-«ire« 10000) yPossibly only half of this will exist 
(defvar *a-me»ory« (make-array *a-«caory-si2e*) ) 

(defvar «b-memory« (make-array 400)) 

(defconst «page-si2e» 400) 

(defconst «quantum-si2e« «page-si2e«) ;smalt for now. And no virtual mcppina. 

(defvar *address-8pace-map« (make-array 2B00) } ;by 5 

(defconst »a-memory-vtrtua I -address* (!sh 1 IB.)) ;arbitrarily chosen 

(defvar «opcode- table* (make-array 2000)) 
;Registers 

(defvar »vma«) ; Virtual memory address 

(defvar *pma*) ; Physical memory address 

(defvar *mem«) ;Data to and from memory 

(defvar *pc«) ttlacroprogram next-instruction pointer (in halfwords) 

(defvar »instruction«) ;Current instruction 

;6ase registers 

; These contain 28-bit addresses that also point at the internal memory 

(defvar «frame-pointer») 

(defvar »stack-po inter*) jcan count up and down 

(defconst *base-regi ster-I ist* ' (*frame-po inter* *8tack-pointer*) ) 

; These registers control address mapping when internal memory 
;is addressed via *frame-pointer* or «3tack-pointer* 
(defvar *stack-buf fer-address* 0) ;nust be multiple of 400 
(defvar *stack-buf fer-mask* 1777) ;Low 8 bits must be I'm 

;Because I can*t read long strings of 7s 

jThis has to use subl and expt so I can get a 3G-bit mask in flaclisp 

;Note that the araument mij«t h^ « numh^p 



levai-unen icomptie load evai) 
(defun (frask macro) (x) ; 

(let UQ ( (defaui t-cons-area workina-storaae-area) ) 

(sub l (expt 2 (cadr x)))))) 

;Basic Uord Formats 

(comment ; comes from SYSDEF now 

(eval-wi'ien (compile evai load) 

(defconst «data-types* '( ;somewhat preliminary! 

;Lou 16 types 

dtp-null dtp-nil dtp-sumbo! dtp-extended-number 

dtp-external-value-ce^T»potnter dtp- locative 
dtp-list dtp-compUcd-funct ion 

dtp-array dtp-c t osure dtp-entity dtp- lexical -closure 

dtp-select-methoo dtp- instance dtp-header-p dtp-hsader-i 

;Fixnum uses up IG types 

dtp-fix dtp-fix dtp-fix dto-ftx dtp-fix dto-fix dtp-fix dtp-fix 

dtp-fix dtp-fix dtp-fix dtp-fix dtp-fix dtp-fix dtp-fix dTp-ftx 

;Flonu» uses up IB types 

dtp-float dtp-float dtp-float dtp-float dtp-float dtp-float dtp-float 

dtp-float dtp-float dtp-float dtp-float dtp-float dtp-float dtp-float 

dtp-float dtp-float 

;High lb types (note: dtp-even-pc. dtp-odd-pc must be and 10 

: in this qrouo of IS) 
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dtp-even-pc dtp-gc- forward dtp-one-q-f onward dtp-header-forward 
dtD-body-foruard dtp-E5 dtp-Go dtp-b7 
dtp-odd-pc ritp-71 dtp-72 dtp-73 
dtp-74 dtp-75 dtp-75 dtp-77)) 

(defconst «cdr-codes» ' (cdr-next cdr-ni I cdr-noraat cdr-spare)) ' 

) ;evat-uhen 

} ; comment 

(declare (special «dsta-tupes« «cdr-codes*}) ;inSYSDEF 




(def Macro cdr-field (q) Midi? 4202 ^q)) 



(dcf macro sct-cdr (value cdr) 
(let ((cdr-code 

(if (numperp cdr) cdr f ftnd-po^f t/on-]n- 1 tst cdr «cdr-codes«) )) ) 
(or cdr-code (ferror nil '-S undefined cdr code** cdr)) 
Mdpb , cdr-code 4202 .value))) 

(defffiacro set-type (ptr dtp) 

(let ((dtp-code (f ind-posi t ton-in-1 ist dtp «data-tupes*) ) ) 
(or dtp-code (ferror ni i "-..S undefined data tupe^ dtp)) 
(if (memq dtp ' (dtp-fix dtp-float)) 

Mdpb ,(lsh dtp-cede -4) 4002 (logand (mask 32.) ,ptr)) 
'(dpb ,dtp-coae 340S (logand (mask 2S.) ,ptr))))) 

; Number fields (fixnun onlu far now) 



(defun unbox-fixnuffl (q) 

(- (logxor (fixnum-field q) 1_31.) 1_31.)) 

:;; -«- Mode: Lisp; Packaqe;nicro: Base: 8; Lowercases t -*- 
;;; (c) Copyright 1382, Symbolics, Inc. 

; Simulator of L-wachine wicrocode 

; This file gets loaded after the architecture definitions 

m 

(declare (load *tiii)) 

m 

(declare (»iexpr address-add) 

(fixnua (even- instruct ton fixnum) (odd-'mstruct ion fixnum) 

. ( i nstruct i on-opcode) ( i nstruct i on-uns i gned- i mmed) ate) 
(instruct ion-signed- immediate) (pc-add fixnum fixnum) 
( instruct ion-baseno) (instruction-offset) 
(stack-address fixnum) (address-add no type fixnum))) 

5 Accessor aacros for named memory slots 

(deftnacr 

(defmacr 

(comment 



(deftnacro top-of-stack i) * (aref *b-memcry* 350)) 

(defmacro stack-timit Maref *b-meniory* 3441) 

(comment 

(defmacro temp-1 * (aref *b.memory« 3S1)) 

(def macro temp-2 () Maref «b-memory« 352)) 

(defmacro teffp-3 Uaref ^o-memory* 3£3)) 

(defmacro temp-4 () * (aref «b-memory« 3B4)) 

(defmacro temp-5 Uarei *b-memory» 35S) ) 

(defmacro trans- temp i) Maref «b-meraory« 365)) 



): comment 

(defmacro stack- low Maref «a-memory« 2403)) 
(defaacro a-stack-overf low Maref «a-memory« 2484)) 

; Accessor macros for fields of the VMA 

(defmacro vma-cuantum M// (pointer-field «vma») «quantum-st2e«) ) 
(oefmscro vma-page M// (pointer-f ield *vma«) *page-si2e«) ) 
Idef macro vma-wi thin-page M logand «vma* ,(1- «page-size») ) ) 

sAccessors for instructions as fetched from iiemory 

(defun even-instruction (mem) (dpb (Idb 4201 mem) 2001 (Idb 0020 mem))) 
(defun odd- instruct ion (mem) (dpb (Idb 4301 mem) 2001 (Idb 2020 mem))) 

;Accessors for fields of the instruction 

(defun instruct icn-cpcode () (Idb 1011 «instruct ton*) ) 

(defun instruct lon-no-operand-opcode () (+ (Idb 0011 «instruct ion«) 1000)) 

(defun instruct lon-unsianed- immediate 

(Idb 0010 «: nstruct ion*) ) 

(defun instruct ion-si gned- immediate 

(- (logxor 222 (instruction-unsianed-immediate)) 200)) 

(defun instruct ion-baseno (Idb 0701 ^instruct ion*) ) 
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(defun instruction-offset (J (Idb 0S97 '« instruct ion*) ) 

:Addres5 arithmetic for internal memory 

(defun addres5-8dd (oaseno offset Aoptional (aacrocode nil)) 

(let ((base-reg (if (numberp baseno) (nth bascno «base-regi ster-li st*) 
baseno) ) } 
(and macrocode (eq base-reg '«8tack-potnter«) 
(setq offset (1+ (logior offset 75^3)))) 
(tct ((addr (logand (+ (symeval base-req) offset) 
(1- «a-Bicmory-si2e*f) ) ) 
(stack-address addr)))) 

(defun stack-address (addr) 

(+ (iooand addr «s tack-buff er-mask«) »stack-buf fer-address*)) 

(def macro local -operand 
Maref «3-fneffiory» 

(address-add (instruct Ibn-baseno) (instruction-offset) t))) 

;Acce8sor macros for the current frame 

;The currently executing function 
(defmacro frame-function 

Maref *a-meffiory« (address-add **frane-pointcr* -1))) 

;A ftxnum full of various fields 

(defmacro frame-mi £c-data 

Maref *a-»en;ory« (address-add '«frame*pointor* -2))) 

;CaI ler's return PC 
(defmacro frar-.e-return-pc () 

Maref *a-memory* (address-add '♦frame-pointer* -3))) 

;Top of previous frame • value to restore to ( stack-p ointer) 
;The cdr code of this word is the value disposi t ion~ 
(defmacro frame-previous-top 

Maref *a-memory* (address-add *»fr3me-po inter* -4))) 

;Base of previous frame • value to restore to (arg-po inter) 
(defmacro frame-prevtous-frame 

Maref *a-memory* (address-add "«frame-pointer« -5))) 

;Fields in frame-mi sc-data 

(defmacro frame-number-of-args 
MIdb 008S (frame-misc-data))) 

(defmacro frame-cleanup-bits 
MIdb 0BC5 (frame-mi sc-data))) 

(defmacro frame-buf fer-underf lou-bi t 
MIdb 0601 (frame-misc-data))) 

y 

;PC manipulation 

(defun pc-add (pc offset) 

(let ((uord (+ (pointer-field pc) (ash offset -1))) 

(halfuord (iogxor (Idb 3701 pc) offset (if (minusp offset) 1 0)))) 
I ( f (oddp hai fword) 

(set-type uord dtp-odd-pc) 
(set-type word dtp-even-pc) ) )) 

(defun pc-p I US-number (pc offset) 
(let ((word (pointer-field pc) ) 

(halfuord (+ (Idb 3701 pc) offset))) 
(aetq uord (+ uord (if (minusp halfuord) (1- (// halfuord 2)) 
,. , (// halfuord 2)))) 

(rf (oddp halfuord) 

(set-type uord dtp-odd-pc) 
(set-type uord dtp-even-pc)))) 

(defun pc-oddp (pc) 

^"91 A=e'*9P ^*=it) 3701 pc)))) 
sComparisons 
s these are a I I assumed to exist in the r«a) Machine 

(defun equal -pointer (x y) j2S-b it 

(• (pointer-field x) (pointer-field y) ) ) 

(defun equal-fixnum (x u) ; 32-bit 



jetun equai-tixnum ix uJ 
(» (f ixnum-f ield x) (f ixnum-f ield y) ) ) 

(defun equal-typed-pointer (x y) 
{^ (logand (mask o4.) x) (toga 



ogand (mask 34,) y) )) 



; 34-bit 
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(defun equal-word (x y) ;3G-bit 

(« X y} ) 

(defun greater-pointer (x y) jZS-btt 

{> (pointer-field x) (pointer-field y))) 

(defun lesser-pointer (x y) ;28-bit 

(< (pointer-fieid x) (pointer-field y) ) ) 

(defun greater-f (xnurs (x y} ;32-bit 

(> (undox-f ixnuR x) (unbox- ftxnum y) ) ) 

(defun lesser-f ixnuR (x y} ;32-brt 

(< (unbox-f txnu» x) (unbox-f fxnua y) ) ) 

(defun tesser-f ixnum-unsigned (x y) ; 32-bit unsianed 

(< (f ixnuiB-f ieid x) (f ixnua-f ield y))) 

(defmacro data-type? (word firest types) 
(coneify 'or (loop for type in types 

collect (setectq type 

(dtp-fix '(- (high-type-field ,uopd) 1)) 
(dtp-float M- (high-tupe-field .word) 2)) 
(otherwise * (• (type-field ,word) 

, (f ind-posi tion-in-I ist type 
»data-type5»)))))n 

(defniacro cdr-code? (word 4rest cdrs) 
(consify 'or (loop for cdr in cdrs 

collect M" <cdr-field ,uord) 

, (cond ((numberp cdr) cdr) 

( (find-posit ion-in-l ist cdr «cdr -codes*) ) 

(t (ferror nil "^S illegal cdr code" cdr))))))) 

;NIL and T constants 

(defvar «nil« (set-type 8 dtp-nil)) 

(defvar «t* (set-type 525252 dtp-symbol)) 

(eval-when (compile load eval) 
(defun consify (head list) 

(cond ((null list) (ferror nil "something la nisslna")) 

((null (cdr list)) (car list)) 

(t (cons head I ist)))) 
) ; eval -when 

;In real machine this comes out of the ALU. This routine is a crock. 
;Return T if bits 31 and 22 of the atu output differ. 
(defun overftow-D (alu-output) 

(not (zerop (logand (ash alu-output -31.) (ash alu-output -32.) 1)))) 

(connent ;not used any wore 

;Stands for AND of deciding to trap and the arithmetfc trap-address PLA 

(defun encode-ar i thmet ic-trap-condi t ion 

. ^ , (obus-type-nismatch bbus-type-mi snatch overflow abus bbus) 
(and (or abus-type-mi smatch bbus-tyoe-ffii smatch overflow) 
(cond ((data-type? abus dto-ffx) 

(cond (Tdata-tupe? bbus dtp-fix) *f ixnum-f ixnum) 

((data-type? bbus dtp-float) * f ixnum-f lonum) 
((data-typo? bbus dtp-oxtended-number) * f ixnufc-extnum) 
(t 'error))) 
((data-type? abus dtp-float) 
(cond ((data-type? bbus dtp-fix) ' f lonum-f ixnum) 

((data-type? bbus dtp-float) ' f lonum-f Icnum) 
((data-type? bbus dtp-extended-number) 'axtnum-extnum) 
(t error)}) 
((data-type? abus dtp-extended-number) 
(cond (Toata-tyoe? bbus dtp-fix) 'cxtnum-f ixnum) 

((data-type? bbus dtp-float) 'extnum-extnum) 
((data-type? bbus dtp-extended-nur.ber) 'extnum-extnum) 
(t error))) 
(t 'error)))) 
);comment 

; Internal Beaiory (A memory) address conversions 

;The A memory can be addressed cither directly or bu a 
$base register plus an offset. The two base regietSrs are the 
; frame pointer and the stack pointer; the (atte? is an up/down 
:^2^H*=«;i ^*:^"« /"° 5f" registers are 28-bit registers that 
: read and write from the mam data path. The offset that can 
;be added can be the low 8 bits of a macro-instruction wth 
iS^-aTcrScoSS constani?^ ^°*'^''« ^^ '^" microcode and the 8th bit, 
inf^Lj^LS^fK*" PO'"^*: •« u«d as a base, the high bits of the 
a subtraction (?hi?;:7 ^^^^ ^^* ^° ^ ^° """• '" effelt? 
;i 2acroinsi?CctiSr;).°"'^ ''^^""^ "'^^^ *^« °^^"* """ '^^^ 
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; adder and the special register. The special register and Bode 
;controt are changed when euitching betueen the BSin and auxiliary 
istack buffers. 

:For function calling to work efficiently uith this, the main 
;data path has to be abie to add or subtract a small nicrocode 
jconstant from either of the base registers, plug in a data type, 
;and put the result on the output bus uhence it can be written 
;into internal «emoru or into a base register. The address adder 
;cannot be used for this since it has to be a 28-bit add. The 
I necessary Microcode constants are stored in B aenorg. 



;This function sets up a stack at virtual addresses 32099-37777, puts the 
; first IK of it into the stack buffer in the first IK of A memory, and sets 
;up the frame pointers to give a frame for the specified function and 
;arguments. Also sets the PC to the function's starting address. This only 
; works for functions that use the fast-ara sequence, 
(defun ini tiai ize-sg (function 4rest argsf 
;;f1ap locations 32899-23777 into A oemory 0-1777 
: — no map yet — - 
;:Set pointers to initial frame 
isetq *frame-pointer« 329^5) 
;;Build the frame header 

(setf (frame-misc-data) (set-type (length args) dtp-fix)) 
(setf (frame-buf fer-underf low-bi t) 1) 
(setf ( frame- funct ion) funct i on) 

;Note that the return PC is given valid data type so that a data 
: type check does not go off prematurely before the fra«e cleanup 
; check when returning out the top of a stack groups 
(setf (frame-return-pc) (cet-type 9 dtp-even-pcH ;no caller 
(setf (frame-previous- top) 

(set-cdr Iset-type 31777 dtp-!ocat i ve) 1)) ;empty pdl, for Value 
(setf (frame-previous-frame) *n»l*) ;no caller 

;Depends on pointer-field of frame-previous-frame being zero! 
;;Store the arguments 
(setq «stack-pointcr« 32994) 
(loop for arg in args do (pushval arg) ) 

;;Set up the stack-buffer limit allowing for 199 words of overhead 
;;i.e. space for frame header of overflowing frame, for executing 
;;trap routines, etc. 189 is hopefully much too high. 
setf (stack-limit) (set-type (- 33777 189) dtp-locative)) 
setf stack-low) (set-type 32909 dtp-locative)) 
(setf (a-stack-overf low) (set-type (- 37777 189) dtp-locative)) 
:;Sct the PC 
(setq *pc« (set-type function dtp-odd-pc) ) ) 

(declare («lexpr micro-main-loop) ) 
(defun run-eg ^function Arest args) 

(lexpr-funcal I #' ini t iai ize-sg function args) 

(micro-ma in- loop) ) 

;Debug I/O routines 

; Print a word 
(defun pq (q) 

(princ (nth (cdr-fieid q) «cdr-codes*) ) 
(tyo <f\sp) 

(let ((type (nth (type-field q) scdata-typesst) ) 
(base 8)) 
(princ type) 
(tyo «r\sp) 
(selectq type 

(dtp-fix (prinl (unbox-f ixnum q) ) ) 

(dtp-float (prinl (f ixnum-f ield q))) : temporary 

(otherwise (prinl (pointer-field q))))) 
(princ •( |) ;For people who uapcar this 

tfu (values)) 

:Print the pdl 
(defun pp () 

(loop for i from «frame-pointer« to «stack-pointer« 
as i i • (stack-address i) 

do (format t "^^A^: -^0 - ii (aref s:a-«eBcry« ii)) 
(pq (aref «a-memoru» ii))) 
(cond ((not (- (top-of-stack) 
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. i3':*IxX?""^"'°^y* (stack-address «stack-pointer«)) ) ) 
(format t "-^TOS-regi step: -^ " (top-of-«tack) ) 
^ ^ Ipq (top-of-stack)))) 
tfQ (values)) 

;Print the current frame (or any frame) 
(defun pf (Soptional iap «fra;T!s-pointer») } 
(loop for i from (- ap 5) belou ap 

for label in * (previous- frame previoue-top return-pc » tec-data function) 
as M • (stack-address i ) 

do (format t "-A-OC-A) :-22T^ ■ li label (aref «a-«emoru« ii)) 
(pq (aref *a-memory« ii))) 
ffQ (values)) 

?PpInt contents of one or more memory locations 
(defun pffl (from ^optional (to from)) 

(loop for addr from (pointer-field from) to (pointer-field to) 
as data • (raw-mcm-read addr) 
do (format t "^--0// ^ " addr data) 
(pq data) ) 
ifQ (values)) 

;Print contents of one or more internal memory locations 
(defun pim (fror: ^optional (to from)) 
(loop for addr from from to to 

as data ■ (aref »a-meiT!ory« addr) 
do (format t "-^-^/Z -^0 " addr data) 
(pq data)) 
ifQ (values)} 



;nemory referencing uithout transport 

;Thi8 does just enough page mapping to make things work. 
;Virtua! addresses from stack-tou through stack-pointer ^re mapped 
; into the tou l< of interna! memory. 
(defun set-praa-from-vma 

(setq »pma* (if (and (<• (pointer-field (stack-low)) «vma*) 

(<• »vni3» (pointer-f ieid «stack-pointer*))) 
(+ »a-memory-virtuai-address« (logand 1777 »vb3«) ) 
«vma«) ) ) 

(defun rau-mem-read (address) 
(setq «vma« address) 
(setq «cpma« (pointer-field »viDa«) ) 
(poa-mcm-read) ) 

(defun pma-mem-read 

(cond ((>■ «pma* *a-mefflory-yirtua I -address*) 

(let ((tern (- *{Dma* «a-!neTnory-vir tuai -address*) ) ) 

(or (< tern 18^80) iferror nil "reading garbage address -'S' «pma») ) 
(setq *niem« (aref *3-(nemoru« tern)))) 
C (>• »pma* »main-fflemory-8tze«r 

(ferror nil "reading garbage address •'S" «p«a«) ) 
(t (setq *iaem» (aref *niain-memory« »pma»))})) 

(defun rau-mem-ur i te (address data) 
(setq «vma» address «incm« data) 
(eetq scpma* (pointer-field «vma«) ) 
(pma-mem-ur i te data) ) 

(defun pma-mem-ur t te (data) 

(cond ((>• «pma* *a-«emory-virtual-address«) 

(let ((tern (- «rpfna* «a-mefflory-v irtua I -address*) ) ) 

(or (< tew 18883) iierrar nil ^'writing garbage address -.S" «pma*) ) 
(aset data *a-memory* tern))) 
((>- «pm3* «njain-B;er,ory-si2e*} 

(ferror nil ''writing garbage address -^S" spma*) ) 
(t (aset data *main-meinory* *pna«) ) ) ) 



(defun simulate-transporter (transport- type) 
(loop doing (pma-mem-read) 

until (selectq (nth (type-field »mem«) «data- types*) 

((dtp-nil dtp-symbol dtp-extended-number dtp- locative dtp- list 
dtp-compi led-funct ton dtp-array 
dtp-closure dtp-entity dtp-lcxical-closure 
dtp-instance dtp-fix dtp-float dtp-even-pc dtp-odd-pc) 
t) ;Good types 

((dtp-nuit) 
(or (memq transport-type Murtte bind)) 

(ferror nil "unbound var iable/Zdef ini t ion") > ) 
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((dtp-header-p dtp-header-i J 
(or (eq transport-type 'header) 

(ferror nil "bad data type encountered"))) 
( (dtp-external-value-ce! I-pomter) 

<memq transport-type '(bind no-evcp))) 
( (dtp-one-q-f cruard dtp-header-forward) 
(setq »vr:3« «memx) 
ni t) 

{ (dtp-body-foruard) 
(setf (trans-temp) «vma«) 
(rau-mem-read <tmen*) 
(or (data-type? msicrr.% dtp-header-foruard) 

(ferror nil **bcdu forward doesn't point to header fwd")) 
(setq 4cvma« (dph (-^ Tpointer-f ieid »mem») 

(- (pointer-field (trans-temp)) 
(pointer-field «vma*))) 
0034 (trans-temp))) 
nil) 

(otherwise (ferror nt I "bad data type encountered"))) 
do (setq vpma* (setq 4rvoia« (pointer-f ietd «vma») ) ) ) ) 

(defun mem-read (address ^optional (transport-type *data)) 
(transport-address address transport-type) 
»ffleTn«) 

(defun mem-write (address data ^optional (transport-type 'data)) 

(transport-address address transport-type) 

(raw-mem-uri ta »vma» data)) ;Actually, doesn't repeat napping phase 
);end conmer^t 

(defun tni tial ize-aain-mernory (^optional (n-words aaaln-asmory-sizew) ) 

(dottmes (i n-words) 
___Jaset (set- type i dtp-nuMJ WRain-memory* i))) 



-4))) 



;In8truction eaulation 

(comnent 

(def var «nc>ct- free-opcode* 0) 

(defmacro def instruct ion (name format Abody emulator) 
' (progn 'compi le 

(add-instruct ion '.name '.format) 
(defun (.name executor} (J 
. , emu later)) ) 

(defun add-instruct ion (name format) 
(let ( (opcode 

(or (car (get name 'instruction-data)) 
(if (eq forwat *10-bi t- immediate) 

;Havc to assign group of 4 opcodes 
?For statuf a tap these actually have to be aligned 
net ((opcode (iogand (+ «naxt-free-opcode« 3) - 
ilSrt? *"ext-frec-opcode« (+ opcode 4)) 
1008) 

(error "out of opcodes" name 'fail-act)) 
opcode) 
(progl jrnext-free-opcode* 

(if (> (setq *neKt-free-opcode« 

(1+ «next-free-opcode«)) 
looo) 
t ^ ,,. (error "out of opcodes" name 'fail-act))))))) 

putprop name (list opcode format) 'instruction-data) 
(if eq format 'IB-bi t-immediate) 
(loop for i from 1 to 3 

do (aset name «opcode-tab!e« (+ opcode i)))) 
(aset name «opcode- table* opcode))). 
); comment 

(defvar *single-step« nit) 

(comment 

:Run using emulator written with def instruct ion 
(defun mam-loop (ioptiona! (starting-pc «pc*)) 
(setq *pc* (if (< starting-pc (mask 28.)) 

(set-type starting-pc dtp-even-pc) ;number - word address 
•tart ing-pc) ) 
(»catch 'halt 

(do ((opcode) ) (nil) 
:; Instruct ion fetch 
(raw-mem-read *pc*} 
(setq * instruct ion* (if (pc-oddp «pc«) (odd- instruct ion »mem«) 

. , (even- instruct ion «mem«))) 

;; instruct ton decode 

(setq opcode (aref «opcode- table* (instruction-opcode))) 
;;ro5Sible debug break 
(cord {(or *single-step* (null opcode)) 
(Im-disasser.ble *pc* 1) 
(break single-step t))) 
;; Increment PC and execute instruction 
(setq «pc* (pc-pl US-number «pc* 1)) 
(*catch 'pclsr 

(funcall (get opcode 'executor)))))) 
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); comment 

;Run using actual microcode emulator 
(defun micro-main- I OOP (^optional (staptlng-pc «pc«) ) 
(setq «pc« (if j< starting-PC (masK ZS.)? 

(set-type start ing-pc dtp-even-pc) tnumber • uord address 
star t ing-pcJ J 
(*catch 'halt 

(do ((opcode) (executor)) (nil) 
! ; Instruction fetch 
(rau-mem-read *pc*) 
(setq »instruction* iif ipc-oad^ «pc«) (odd-instruction »mem») 

, ^ ,, ieven- instruct ion «inea«))) 

:: Instruct ion decode 
(seta opcode (instruction-opcode)) 

(tf {> opcode 375) (setq opcode ( instruct ion-no-operand-opcode)) ) 
(setq opcode (aref *opcode-table« opcode)) 
;;Possible debug break 
(cond ((or «single-step« (null opcode)) 
( Im-di sassemble «pc« 1) 
(break single-step))) 
(cond (null (setq executor (qet opcode 'Bicro-cxecutor)}) 
(Im-d I sassemble *pc« IJ 
(terpri) ^ 

(princ "No micro-executor found. Ip to use SIH executor.") 
(break rtussing-executor) c«ct.uinr. , 

.•Tnrral!S!'^Dr'*!'="^°^ ^^V 9Pcode * cxecutor ) ) ) ) 
;; increment PC and execute instruction 
setq *pc* (pc-plus-number »pc* 1)) 

«a;ch^?p=T^-"^?S^^^f^SLtor)) "^'"'^=« '°' *««P°"^W — °^W control 
(setq *pc* (aref *a-memory« 2553))))) .,, 
;Excessiveig sispie aseembier 

(def macro def macrocode (pcvar start ing-uord &body code) 

Mprogn (setq , pcvar (set-type .start ing-word dtp-even-pc)) 
. ,(loop for addr upfrom (« 2 start ing-uord) 
for inst in code 
collect '(l»-assemblc ,addp \in8t)))} 

(dcfaacro defunct ion (fcnvar start ing-uord (ain-nargs max-nargs rest-ara) 
constant-l ist 
&body code) 
(or aax-nargs (setq «ax-nargs flitn-naras) ) ^defaults to no optionals 
. — tjhat to do about this? No encoding in entry instruction for 

; a function with no constants! 

(or constant-list (setq constant-l i st (Met «nii«))) 
*lprogn 'coropi le 

; The pointer to the object points at the entry instruction 
(setq .fcnvar (set-type ,1+ starting-word (length constant-l ist) 2) 

dtp-compi led-function)} 
;dtp-header-i type-compi led-code, lengths of both parts, interp info 
laset (set-cdr (set-tupc 

, (+ fl- (length constant-list)) !Length-3 of Q part 

^'^ i(( ^"^ < length code) 2) 2);Length of non-Q part 

dtp-header-i) 
8) 
»nain-memory* , star t ing-word) 
; list of function name and debug info 
(aset «nil» «main-memory« , (+ start ing-uord D) 

;constants/value-function cell references in rnv^rss order 

; For now. we assume cell references are just numbers! 

,a(ioop for addr downfroB (+ starting-word 1 (length constant-list)) 
for const m constant-list 
do (if (zerop (type-field const)) 

(setq const (set-type const dtp-locative))) 
collect Maset .const *aa i n-memory« ,addr)) 
;entry instruct ion 
(aset , (maKe-entry- instruct ion ain-nargs aax-nargs rest-arg 

(1- (length constant-l ist))f 
*Biam-aemory« , (+ start ing-uord 2 (length constant-i ist) ) ) 
;The code 
. ,(ioop for addr upfroa (1+ (» 2 (+ starting-word 2 

(length constant-list)))) 
for inst in code 

collect Mim-asseable .addr Mnst)))) 

(defun aake-cntry-instruction (ain-nargs max-nargs rest-arg header-offset) 
(tf 1> ain-narqs max-nargs) 

(fo-ror nil "ain-nargs ^ > aax-nargs -*0 ?" ain-nargs aax-nargs)) 
4+ heaaer-of f set 

(Ish (if (or rest-arg (> max-nargs 4)) 

(- (nth max-narqs '(13 6 18. 15.)) 
(- aax-nargs ain-nargs))) 
S) ) ) 

;Not called assemble because ncomplr has a global symbol by that name 
(defun la-assemble (hal fword-addr code) ^ ^ ^ u 

(let ((op (car code)) (arg icadr cods))) 
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(let ((opcode (car (get op ' instruct ion-data) )) 
(format (cadr (get op * instruction-data))) 
(inst)) 
(and opcode (setq inst 

(if (< opcode leea) (Ish opcode 8) (+ 377 9 (- opcode 1880))))) 
(selectq fornat 

(no-operand) j 

( (uns i gned- i nmed i a te-opcrand 8 1 gned- i vaed i ate-operand constant-operand 
indirect -operand) 
(eetq inst (dpb arg 8810 inst))) 
( (s t gned-pc-relat tve unsigned-pc-relative) 

(setq inst (dpb (conver t-branch-Jcngth hal fword-addr arg) 8818 inst))) 
(18-D i t- i mmed i a te-op«rand 

(setq inst (dpb arg 0818 (+ inst (logand 3.8 arg))))) 
(address-operand 
(letq inst (+ inst 

(l8h (or (f ind-posi tion-in-I ist (cadr code) 

• (arg stack)) 
(ferror nil "*S iMegat base pntr" code)) 
7) 
(logand (if (eq (cadr code) 'stack) 
(+ (caddr code) 177) 
(caddr code)) 
177)))) 
(ni! (ferror nil "*.S undefined instruction" op)) 
(otherwise (ferror nil "*rS instruction in bad for 
(aset (dpb i 4882 ;ftxnum data tupe 

(dpb (Idb 2031 inst) (if (oddp hal fuord-addr) 4301 4281) 
(dpb inst (if (oddp haifword-addr) 2020 0820) 

(aref *main-ffleffioru« (// hal fuord-addr 2))))) 
*mam-memory« (// ha I f word-addr 2))))) 

Convert branch length to hardware format. 

The hardware takes the branch offset, rotates it right one bit, and 
adds it to the PC, Thus there is a carry froii the word offset into 
the halfuord offset, rather than the reverse as you night expect. 
, ., This function really is a case where you want to divide by 2 with ASH, not with // !! 
(defun convert-branch- length (address length) 

h) (evenp address)) 18))) 
sp word-offset) 1 8)))) 



format ^-S" op format))) 



This function really is a case where you want to divide by 4 
^un convert-branch- length (address length) 
et« ((word-offset i^ Tash length -1) (if (and (oddp length) 
(ha If word-off set (ioqxor ( looand 1 length) (i f (Btnusp 
(■f (ash word-offset 1) halfuord-o? fset))) 



(defun l»-disassemble (pc n-insts) 
(loop repeat n-insts 

as inst « (if (pc-oddp pc) 

(odd-instruction (aref smain-memory* (pointer-field pc))) 
(even-instruct ion 

(aref stmain-memory* (pointer-field pc)))) 
as op - (aref «opcode-table» (if (- (Idb 1110 inst) 377) 

(+ (Idb 8011 inst) 1000) 
(Idb 1811 inst))) 
as f»t " (second (get op 'instruction-data)) 
as inn - (logand (mask 8) inst) 
do (format t *'-&-0(-0) ^ --A " 

(pointer-field pc) (if (pc-oddp pc) 1 8) 
inst op) 
(seiectq fmt 

( ( uns t gned- i mmed i ate-oper and uns i gned-pc-re I a t i ve) ipr i nl i mm) ) 
((si 9ned- i mmcd i a t e-oper and s i aned-pc-re ( 3 1 i ve) 

(pr ml (- (logxor 203 imn) 200))) 
(10-bi t-tmmediate-operand (prinl (logand (mask 18.) inst))) 
(address-operand (prinl (nth (Ish iaa -7) Marg stack))) 
(tyo U/\) 
(prinl (if (< innr 2881 imn 

<- (logand 177 imm) 177)))) 
((constant-operand constant-pc-reiat ive indirect-operand) 
(format t "*A -^'' fmt imn))) 
(setq pc (pc-plus-number pc 1)))) 



t-type *pc» dtp-odd-pc) 
(set-type (1+ *pc») dtp-even-pc) ) )) 

ntt 

go in one cycle 



(defun inc-pc ^ , 

(setq «pc* (if (data-tuoe? «pc« dtp-even-pc) 
(set-type *pc» dtp-odd-pc) 

•Support routines for instructions 

; These would be open-coded .„. 

(defun pushval (val) 

(setq val (set-cdr vaf cdr-next)) 

(aset val «a-mcmory« (address-add 'scstack-pointer* 1)) 

(setf (top-of-stack) val) 

(incf «stack-pointer») ) 

(comment 

(defun popval () 

(progl (top-of-stack) 

(setf (top-of-stack) (aref «a-memory« 

, . , ^ , ^ . ^ ,,, (address-add '«stack-pointer« -1))) 
(decf »stack-pofnter*>)) 

(defun newtop (val) 
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(setq val (set-cdr val cdr-next)) 

(aset val ^a-memory* (address-add •«8tack-pointep« Q)) 

(setf (top-of-6tack) vat)) 

(defun next-on-8tack 

(arcf «a-iie»ory« (address-add •»8tacK-pointer» -1))) 

;This is like doing two popvai's and then a pushval 
(defun pop2push (val) 

(setq val (set-cdr val cdr-next)) 

(aset val «a-memory« (address-add •«stack-po inter* -1)) 

(setf (top-of-stack) val) 

(decf »stack-pointer«)) 

(defun pushval -ui th-cdr (val) 

(aset val «a-memory* (address-add '^stack-pointer* D) 
(setf (top-of-stack) vai) 
(incf «stack-pointer«) ) 

;Helpcr functions for arithmetic 

; These do arithmetic but trap to overf low-bignua-creatc if the 
;result doesn't fit in a fixnum. 

;In the simulator this thinks a lot, in the real machine it 
; needs to be built in (conditional branch on ALU 32-bit overflow flag). 
(defun p I US-check-over f tow (opl op2 stack-adjustBient) 
(let ((res (-K opl op2))) 

(or (and {<- -1^31. res) (< res 1 31.)) 

(overf low-bignum-create res stack-adjustment)) 
res)) 

(defun minus-check-overf low (opl op2 stack-adjustment) 
(let {(res (- opl op2))) 

(or (and (<« -1^31. res) (< res 1 31.)) 

(overf low-bignum-create res stack-adjustment)) 
res)) 



;Sone timpte instructions 

(dcf instruction halt no-operand (»throu 'halt 'halt)) 

(def instruction push-iwmed signed- immediate-operand 

(pushval (set-type ( instruct ion-signed-immediate) dtp-fix))) 

(def instruct ion push-local address-operand 
(pushva i ( i oca I -operand) ) ) 

(def instruct i on pop- 1 oca I address-operand 
(setf ( local -operand) (popval))) 

(def instruct ion movcm-local address-operand 
(setf (I oca I -operand) (top-of-stack))) 

(definstruction add-iujued signed- immediate-operand 
(or (data-type? (top-of-stack) dtp-fix) 

(take-arithmetic-trap 'add * signed-immcd)) 
(neutop (set-type (pius-check-overf low (unbox-f ixnum (toD-of-stack)) 

k\ nstruc t i on-8 i gned- i rnmed i ate) 

dtp-fix))) 

(definstruction add-locat address-operand 
(or (and (data-type? (top-of-stack) dtp-fix) 

(data-type? ( I oca I -operand) dtp-fix)) 
(take-arithmetic-trap 'add 'local)) 
(newtop (set-type (plus-check-overf low (unbox-f ixnum (top-of-stack)) 

(unbox-f ixnum ( I oca I -operand) ) 

dtp-fix))) 

:This will be format-3 when I bother tiaulating those 
(definstruction add-stack no-operand 

(or (and (data-type? (top-of-stack) dtp-fix) 

(data-type? (next-on-stack) dtp-fix)) 
(take-arithmetic-trap 'add 'stack)) 
(pop2push (set-type (pius-check-overf low (unbox-f ixnum (top-of-stack)) 

(unbox-f ixnua (next-on-stack)) 

dtp-fix))) 

(definstruction push-constant constant-operand 
(pushval (mem-read (- (frame-function) 

( i ns true t i on-uns i gned- i mmed i ate) 

(definstruction push-specvar indirect-operand 
(pushva! (mem-read Imen-read (- (fran;e-f unction) 

( i ns true t i on-uns i gned- i mmedi a te) 

•no-evcp)))) 
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{This is the fopmat-3 version, others ut M exist, too. 
(def instruct ion car-stack no-operand 

(or (data-type? (top-of-stack) dtp-list dtp-locative) 

(take-pre-trap «argtup-trap-handler*) ) 
(ncutop (mem-read (top-of-stack)))) 

(def instruct ion cdr-stack no-operand 
(or (data-type? (top-of-stack) dtp-list dtp-locative) 

(take-pre-trap «argtyp-trap-handier«) ) 
(■ea-read (top-of-stack) 7 

(cond ((data-type? (top-of-stack) dtp-tocat ive) ;delayed test for speed 
(neutop »meni3») ) 
((cdr-code? *mem* cdr-normal) 

(neutop (mem-read (1+ »vma*)))) 
((cdr-code? »mem* cdr-next) 

(neutop (1+ »vm3*) ) ) 
((car-code? «mem* cdr-nrl> 

(neutop *ni i«) ) 
(t (f error nH "Where did this bogus cdr code come from?")))) 

(def instruct ion times-stack no-operand 

(or (and (data-type? (top-of-stack) dto-fix) 

(data-type? (nsxt-on-stack) dtp-fix)) 
(take-arithmetic-trap 'add 'stack)) 

•; ovcrflou checking 

(popZpush (set-type (times (unbox-f ixnum (top-of-stack)) 

(unbox-f ixnum (next-on-stack) ) ) 
dtp-fix))) 

(def instruction branch-rerop signed-pc-re(at i ve 
(or (dat.-^-tupc? (top-of-stackJ dtp-fix) 

(take-arilhmetic-larg-trap 'zerop 'stack)) ; or something 

(if zcrop (f ixnup-f ield (top-of-stack))) 

(setq *pc« (pc-add *pc« ( instruct ion-signed-immediatc) )) ) 

(popva I ) ) z 

(def instruct ton branch-not-zerop signed-pc-relative 



Jef instruct ton branch-not-zerop signed-pi 

(or (data- type? (top-of-stack) dtp-fix) 

(take-ari thmetic-larg-trap 'zerop ' 



'zerop 'stack)) i- — or something 
(if (not (zerop (f ixnum^lield' (top-of-stack)))) 

(setq »pc» (pc-add »pc« ( instruct i on-signed- inmedi ate) )) ) 
(popva t ) ) 

(def instruction return-stack no-operand ;pseudo format 3 
(common-rcturn-processing (top-of-stack) ) ) 

(def instruct ion pop j-no-value no-operand 

(or tdata-typeV (top-of-stack) dtp-even-pc dtp-odd-pc) 

(ferror nil "popi to non-PC)) 
(setq «pc* (popval)); 

U, ' ;heh. heh 

(proon 'compi le 
•,iloop for nargs from to S nconc 

(loop for ^value-disposition in '(effect vafue return multiple-value) 

Mdef instruction , (intern (format nil "CALL-vA--^" 

. _,. ^ value-disposition nargs)) 
indirect-operand 
(common-call -processing \ value-di sposi t ion '.nargs 

(get-«i ink-opersnd) ) ) ) ) ) 

(de fun get-* I ink-operand 

(mem-read (mem-read (- (frame-function) 

( r ns true t i on-uns i gned- i mmed i ate) 

'nc-evcp))) 
(declare (special »stack-buf fer-overf lou-handler«)) 

^^ffv2.""°""^?"'?[°?"®'"9 (value-disposition nargs fen) 
'(nu^huSV%Si!?^*r ^^^\ ^""^ ^*^*'y overlapped uith those tuo memory cycles 
(pushval (set-type »frame-po inter* dtp-locat ive) ) «c™ory cycies 
(pushva I -u I th-cor 

(dpb (f ind-posi tion-in-l ist value-disposition 

/orr? 'i*^!®-! value return multiple-value)) 

'^t^^i ^ , :cdr field 

(pushval *pci)^^* «stack-pointer« (+ nargs 2)) dtp-locative))) 

(Dushvf! i^^^'^yP* "^""9^ dtp-fix)) ; initial frame-misc-data 

iS;^'(Slla!?Spe? fcn dtp-compi .ed-funct'iS^?-^°"^* '•'"^""=^'°'^ 

(ferror nil "call of non-function")) 
jsetq »pc» (set-type (pointer-field fcn) dtp-odd-pc)) 
(setq *frame-pomter* (1+ *stack-pointer«) ) 

-N^te that ?hV.^h!^;^^''''^I°r*"^'"y ^'"^P* *^3* "«^ *0 ^° O^^- 

-tSkS thf «JSrf H?.55r^ -before- copying up the arguments so as to 

Ilu??? TcVut rs%:^5ld'?l?er'?^^ *° ^^ ^"^^^^' adSi t ion^al%x^?i^?t'c^;^^?^S*" 

^'^ }?^5f^5'""?°i"^*'" *5tack-poInter» (stack-limt t)) 

(taKe-post-trap «st3ck-fcuf fer-overf lou-handler«) ) 
(resume-cotnmon-ca I I -processing nargs)) 
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;Comc5 back in here after taking a stack-buf fer-overf low trap, 
;Uriting it this way doesn't really express the control structure 
;in the real machine. See the micrococie in the 'stack* file. 
(defun resurre-ccnnicn-cal ^processing (nargs) 
(pem-read »rpc«) 

;;Nou the entry instruction is in ^nem*. Perform the fast entry cases, 
(let (iargdesc (nth (Ido 1894 «mern*) 

M(0 . 777) (e .8) (8 . 1) (1 . 1) 

(8 . 2) (1 . 2) (2 .2) (8 . 3) (1 .3) (2 . 3) (3 . 3) 
(8 .A) (1.4) (2.4) (3.4) (4.4))))) 
(if (or (< naras (car argdesc)) (> nargs (cdr argdesc))) 

(ferror nil "urong number of args"}). 
j;Adv3nce the pc to skip over unnecded opt ional-arnunent initializations 
(and (not (zerop (Idtt 1004 «mem*))} 
(> nargs (car argdesc)) 

(setq »pc« (pc-pTus-number «pc« (- nargs (car argdesc))))) 
;;Now copy up the arguments 
(loop for argno from below nargs 
do (pushval (aref *a-memory« 

(address-cdd *«fraffle-pointer« 

(- argno (+ 5 nargs)))))))) 

(declare (special *return-continuation* *return-c/eanup*) ) 

(defun comtnon-return-processing (vaiue) 
•(setf jtemp-l) value) • — unsafe pointer check 

(cond ((not (zerop (frane-c!eanup-bi ts) ) ) 

(if (data-type? (frame-previous-frame) dtp-nil) ;Reallu in cleanup fen 

(ferror nil "Return out top of SG?")) 
(pushval (temp-D) 

(pushval «return-continuation«) ;PC to return to 
(take- jump-trap «return-cieanup*) ) ) ;Cleanup then retry 
(or (data-type? (frarre-return-nc) dtp-even-pc dtp-odd-pc) 

(ferror nt 1 "Return address not a PC")) 
(setq rpc* (frame-return-pc) ) 

(setq «stack-pointer* (pointer-field (frame-previous-top))) 
(let ((value-disposition (nth (cdr-field (frame-previous-top) ) 

, , ^ , . '(effect value return mul t ipic-vaiue) ) ) ) 

isetq *frafre-pofnter* (potnter-f ield (frame-previous-frame))) 
(selectq value-disposition 

(effect (setf (top-of-stack) (aref «a-memory« 

t ^. t -^ , ,^ ,,,, (address-add **5tack-pornter« 0)})) 
(value (pushval (tem p-1) ) ) ^^ 

(return (comnion-re turn-processing (temp-l) ) ) 

(■ul tiple-value (ferror nil "muI t tpie-vatue ?"))))) 

;8tacktou is the lowest virtuaf address that is or wilt be valid 
;in the stack buffer. Adjust the frsme-buf fer-underf low-bi t of each 
;fraKe in the stack buffer so that the lowest frame has a 1 and the 
;re5t have a 0. 

(defun ad j us t-frame-buf fer-underf low-bi ts (stack low) 
(setq stack low (+ stack low 5)) ;Frame underhang 

(pushval «frame-po inter*) ;Going to use this to address int mem 

(setf (temp-2) *fra3ie-poInter«) 

(loop until (lesser-pointer «frame-pointer« stack low) 
doing (setf (temp-2) *frame-pointer») 

(setf (frame-buffer-undsrf low-bi t) 8) 

(setq «frame-pointer» (pointer-field (frame-previous-frame) ) ) 
f inal ly (setq «frame-pointer» (temp-2) ) 

(setf ( fratne-buf fer-underf low-bi t) 1)) 
(setq «fraae-po Inter* (pointer-f ieid (popval)))) 

}; comment 

;Do this before loading any macrocode! 

( ini t iai (ze-main-mcaory) 

: Trapping 

(coament 

; data-source can be unsigned-immed, signed-immed, local, stack, or mem 
;In the stack case both operands are on the stack, otherwise the 
; first operand is (top-of-stack) and the second is specified by data-source. 
;I"m not sure how this routine is going to work yet* 
(defun take-ar i thraet ic-trap (operation data-source) 
(break arithmetic-trap t) ) ;j(d(c* 

;Another trap routine 

;res is 1 bit too big to fit in a fixnum 

(defun over f low-bi gnum-create (res stack-adjustment) 

(setq «stack-pointer* (+ «stack-pointer» stack-adjustment)) 

(pushval (set-type (abs res) dtp-fix)) ;Truncates to 32 bits 

(pushval (set-type (if (minusp res) 1 8) dtp-fix)) 

(take-post-trap «overf low-bi gnum-create*) ) 

(defun take-pre-trap (pc) 

(setq *pc« (pc-plus-nuraber «pc* -1)) ;Back out of failed instruction 

(take-post-trap pc)) 

(defun take-post-trap (pc) 



4,887,235 
117 118 

(pushvai »pc*) ;Save continuation address (on stack?) 

(take- jump- trap pc)> 

(dafun take- jump- trap fpc) jUhen continuation not to be saved 

(or (nuEPerp pc) it^reaK take-past-trap t)) ;Probably unbound 
(setq mpc^ pc) jJump to trap PC 

(♦throw *pclsr ni!)) ;St art first instruct ion in trap subr 

;;; Flacrocode trap routines start at location 3B869 

;This gets catted uhen a function is being entered and there is not enough 

; space left in the stack buffer. The frane header has been pushed and the 

{Starting pc i s on the stack, however the arguments have not yet been 

;copied Kip into the frame. 

;Uhat ue have to do is to check for genuine stack overflou, 

;dump the lowest stack page out into Rain nemorg, adjust the stack limit 

;up Dg one page, and restart the call at the argunent-copying point. 



(def instruct ion check-stack-overf lou no-operand : dummy 

(if (greater-pointer (stack-litni t) (- 37777 181)) 
(ferror nil "stack overflow*'))) 

(def instruction setup-stack-du»p no-operand 

(let llstacklou llogand t- (stack-limit) 1480) (lognot (1- »p2ge-5i2e*)} ) ) ) 
(adjust-frame-buf fer-underf low-bi ts (+ stacklow *page-size«)r 
(pushvai (set-type »franie-po inter* dtp-locati ve)) tTenporarg needed 
ipushva) (set-type (-f stacktow »page-size«) dtp-locat tve) ) 
(setq »frame-pointer* (pointer-f teTd stacktow)) 

; Also unaap the page fro» the stack buffer - — 

(def instruction increase-stack-limit no-operand 
( incf (stack- 1 iwi t) «page-size«) ) 

; — Also remap the page into the stack buffer — 

;This is pctsrable because its state is contained in the top 

; two words on the stack and in «fraffie-pointer« 

;Only fora of pclsr can be a page fault on th9 very first cycle 

;and after that we need to worry about stack-gc traps. 

(def instruct ion stack-dump no-operand 

(loop until (equal -pointer «frame-pointer« (top-of-stack) ) 

doing ; — real !g eight words at a time 

(raw-mem-wr I te *frame-po inter* 
(aref »a-memory« 

(address-add '«frame-pointer« 8))) 
(incf «frame-pO(nter«) ) 
;;Now restore state and cleanup stack 
(popval ) 
(•etq «fra»e-pointer* (pointer-f ietd (popvai)))) 

(def instruction restart-trapped-cal 1 no-operand 
(setq «pc« (popval)) 
(resuae-coomon-cal 1-processing (frane-number-of-args) ) ) 

(defaacrocode «stack-buffer-overf low-handler* 38888 

; disable interrupts 

(check-stack-overflow) ; this is a dummy 

(setup-stack-dump) 
(stack-dump) 
(increase-stack- 1 imi t) 

: enable interrupts — 

(restart-trapped-cal D) 

(def instruction setup-stack- load no-operand 

(pushvai (set- type *frar.e-pointer* dtp-iocat tve) ) ; Temporary needed 

;; Compute the new lowest virtual address tn the stack buffer. 

;: Uhat I am doing here is probably not reasonable. 

(let ((stacklow (Togand (- (stack-limit) 2888) (lognot (1- «p3ge-si2e*)) ))) 

(pushvai (set-type (+ stacklow *paqe-si2e*) dtp-Tocative)) 

(setq »frame-po inter* (pointer-field stacklow)))) 

(def instruct ion finish-stack-load no-operand 

;-— Also map the page into the stack buffer 

(let ((stacklow (logand (- (stack-limit) 2888) (lognot (1- »page-size*) ) ) ) ) 
(decf (stack- I imi t) *page-siza*) 
(adjust-frawe-buf fer-underf low-bi ts stacklow))) 

:Thts is pclsrable because its state is contained in the top 
:tuo words on the stack and in *frame-pointer* 
;Note that this can pclsr due to trancport 
(def instruct ion stack- load no-operand 

(loop until (equal -pointer *frame-pointer* (top-of-stack)) 

doing , ; — really eight words at a time 

(aset (mem-read «frame-pointer*) 
*a-memory* 

(address-add '♦frame-pointer* 8)) 
fincf *frame-Dointer*) ) 
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;;Nou restore state and cleanup stack 

(popvai) 

(setq »fra{ne-polnter« (pointer-field (popvat)))) 

(def macrocode *return-cont i nuat i on* 30C18 

(re t urn- s tack.) ) .._.. 



Idefaacrocode «return-c (eanup* 'SiiidZd 
(tetup-stacK-load) 
(stack- load) 
(finish-stack-load) 
(popj-no-vatue) ) 

) ; co«»ent 



;Test routine for instructions with args on tha stack and 
;poss(bly an inrnediate operand 
(dcfun try-inst (inst Arcst ar^s) 

(let ((origina!-sp «stack-po inter*) opcode executor) 

(Im-assembie (if (atom inst) (list inst) inst)) 

(loop for arg in args do (pushval arg) ) 

(setq »instruct ion« (logand (nask 18.) (rau-aiem-redd 8))) 

(setq opcode (aref «opcode-table* (instruction-opcode))) 

(setq executor (get opcode 'aicro-executor) ) 

(•catch *pclsr (funcail executor)) 

(let ( («fra«e-pointer« (1+ or iginal-sp) ) ) 

, (PP)) 

(setq »stack-potnt*r» or iginal-sp) ) ) 



F:>1tiach>ucode>ua. lisp. 140 

;;; -«- ttodeiLisp; Packagetflicro; Base:8; Louercasetyes -*- 
:;; (c) Copyright 1982, Symoolics, Inc. 

? tticpocode definitions for the architecture 



(declare (cond ((not (status feature Imucode)) 
(setq **compr I ing-ua*» t) 
(toad *udcls)))) 

;Definitions of locations in hardware memories 
;nust agree uith SID, which initializes them 
(reserve-scratchpad-memory 2480 2410 340 345) 

;A-De«cpy constants set up from the Lisp memory during booting 

; This is nou done by >linach>sysdfi 

; (def areg quote-nil nil *ni l») ; Initialize these in the siisulator 

; (defareg quote-t ni I »t*) 

(defbreg b-quote-nil nil *n) I*} ; Initialize these in the simulator 

(defbreg b-quote-t n\\ *r\n») -In the real mschine, boot Bicrocode sets thea 

(defbrcg-at-toc stack-limit 344) ;U8ed by function-entry aicrocode 

; — ine simulator Knows the numeric addresses of these 

; or. rather, it knows where they used to be! 

; (defareg-at-loc stack-low 2403) ;The lowest virtual address in the stack buffer 

; (defarcg-at-loc a-stack-overf low 2404) :stack-lioit cannot become > this 

: (oefareg-at-loc stack-buf fer-l i»i t 2405) ;highe5t virtual address in stack buffer 

(defa-eg-at-loc a-temp 240o) 

(defareg-at-loc a-teirp-2 2407) 

:2413 and up special purpose temporaries local to particular routines 

(defato«icro a-zero (a-constant 0)) 

;The top-of-stack buffer register on the B side 
sHust be in location 360 for the simulator 
(defbreg-at-loc top-of-stack 3S0) 

; Temporary storage on the B side 
(deforeg-at-loc b-temp 351) 
(defbreg-at-loc b-temp-2 3S2) 
(defbreg-at-loc b-temp-3 363) 

;If this has type dtp-null, it is empty. Otherwise it contains the value 

; which should be restored on the top of the stack if we pclsr. 

;Note that we rely on the ability to write this in parallel with frame-pointer 

; (which doesn t care if we give it a data type of dtp-null; it'e only 28 bits), 

(defareg a-pcl sr-top-of-stack (set-type dtp-null)) 

;B-VnA is (sometimes) a copy of the VHA register. The transporter does 

;not depend on this, but if it changes VdA it also stores the new value 

;here, Tr.e data tupe is indeterminate. B-VHA exists to sake it possible 

;lo coabme the VHA with data from the Abus. 

(defbreg-at-loc b-vma 364) 

(defbreg array-register -event-count (set-type 8 dtp-fix)) 
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;;; Note that location 377 gets clobbered by the hardware 

;;; Trap support for the real nachine 

;NDTE LELL: the NPC ts not valid durtng the ilr^t wjcrolrtstruct ion of a trap 
;handler tactual fy, it always contains the address fro™ which the trap came). 
• ir-^-*^*' first microinstruction must not use anything that compiles into 
;an NPL-successor (for example, it must not call a subroutine). 

;Hicro for the first cycle of a trap handler. 

;Finishe5 the state save bL{ calling for a PUSHJ, which saves 

;the original CPC (now in k?C) onto the stack. The original NPC 

; t« already on the stack. 

(dcfjricro trap-save 

•(microinstruction sequencer push-npc)) 

tflicro for the first cycle of a trap handler, where we aren't going 
;to retry the trapped instruction. 
(dGfajcro trap-no-save C) 

(if teq «rr,achine-verston« 'proto) 

* tmicroinstruct ion sequencer pop))) 

iHicro for the last two cycles of a trap handler, 

;Takes arguments of what else to do in those cycles, that 

;seemrng clearer than throuinq a parallel around the sequence. 

;Ue restore the NPC and the CPC by twice popping the control 

;stack into NPu. In the second cycle we also use NPC as 

;at the source for CPC. Thus the push order is NPC, CPC and 

; the pop orde'- is CPC, UPC. 

(cefBicrc trap-restore (cyde-l cycle-2) 

'(sequential 
(parallel 
♦cycle-1 

(microinstruction wquencer pop-npc spec npc-magic magic 3 magic-mask 3)) 
(para I lei 
, cycle-2 
(microinstruction sequencer pop-npc-and-cpc-from-npc 

spec npc-magic magic 3 magic-mask 3)))) 

jThe same thing broken down into its two component parts 

:Note that trap-save will undo the effect of trap-restore-1, if done 

;in the immediately-following cycle 

(defmicro trap-restore-1 

•(microinstruction sequencer pop-npc cpec npc-magic magic 3 magic-mask 3)) 

(defmicro trap-restore-2 

•(microinstruction sequencer pop-npc-and-cpc-from-npc 

spec npc-magic magic 3 magic-mask 3)) 

;;; flacrocode-trap-taking micros 

•l^^^.°"* °^ * failed instruction, save pc on stack, and jump to specified dc 
;Backing out includes clearing the micro stack j r k k 

;If the second argument is restore-stack, the main stack-pointer is reset to 
:its value at the beginning of the macroinstruction, and a-pclsr-top-of-stack 
;is respected. ^ ^ 

•i^,**?* «cond argument is preserve-stack, stack-pointer remains the same. 
*^?t»19';o,^«*^e-P'*«-t''»P (escape-function-name preserve-or-res tore-stack) 

(,(if (eq preserve-or-restore-stack 'preserve-stack) 'sequential 'parallel) 
(assign pc (pc-plus-number pc (b-constant -1))) 
( take-post- trap , escape- funct i on-nare , preserve-or-restore-stack) ) ) 

;Currcnt instruction completed, now save pc on stack and jump to trap pc 
(defmtcro take-post-trap (escape-function-name preserve-or-restore-stack) 
(selectq preserve-or-restore-stack 

(preserve-stack * (sequent iat (pushval-wi th-cdr (set-cdr pc cdr-normaO) 

i^..f«,.^ .♦^^L *i ♦- . ,^ta>^»-i"nP-trap .escape- function-name preserve-stack))) 

(restore-stack '(sequential (call restore-stack-pointer) 

(pushval-wi th-cdr (set-cdr pc cdr-normaD) 
. .^ , ^ ^ (take-jutno-trap .escape- function-name preserve-stack))) 

(otherwise (retch --S should be PRcSERVE-STAtK or RESTORE-STACK" ««^^« nxac^j j j 
preserve-or-restore-stack) ) ) ) 

jPcIsr out of current instruction and Jump to specified pc 

(defmicro take- jump-trap (escape- funct ion-name preserve-or-restore-stack) 

(parallel (assign pc , (intern (string-append escape-function-name "-ESCAPE-PC"))) 
(jump .(setectq preserve-cr-restore-stack 
(preserve-stack 'pclsr) 
(restore-stack 'pc I sr-restore-stack) 

(otherwise (retch "^S should be PRE SERVE -STACK or RESTiDRE-STAOC" 
preserve-or-restore-stack) ) ) ) ) ) 

;Save continuation pc and jump to trap pc 
(defmicro take- jump- trap-wi th-cont inuat ion 

(escape- function-name continuation-name preserve-or-restore-stack) 
(selectq preserve-or-restore-stack 

(preserve-stack '(sequential (pushval .continuation-name) 

(r-«fn».« .ta^w M««^ ♦-,. (take- jump- trap .escape- function-name preserve-stack))) 
(restore-stack '(sequential (call restore-stack-pointer) 

(oushval .continuation-name) 
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. ^ (take- jump-trap , escape-function-name preserve-stack))) 
(otherwise (retch "-S should be PRESERVE-STA£< or RESTORE-STAdC" 
prcserve-or-restore-stack) ) ) ) 



Ue implement several dispatching schenes for binary arithmetic operations 
This is because at a iater date, we Bay have to trade off dispatch blocks for 
speed in the floating point case. 
Arguments are: 

type - type of instruction (no-operand address-operand signed- iBwediate-ooerand) 
index - the operation index 

no-operand-version - the symbol for the no-operand version of this instruction 
float-version - the symbol of the floating point version of this furictlon 
if non-ex istant, a col lout will occur 
(defaicro check-binary-ar i thret »c-operands-fast 
(type index no-operand-version 

^optional float- vers ion f ixnum-overf lou f lonum-fi xnum- vers ion) 
(let ((ops (selectq type 

(no-operand * Inext-on-stack top-of-stack) ) 
(address-operand ' (address-operand top-of-stack) ) 
(signed-iramediate-operand ' (top-of-stack-a nacro-siqned-imniediate) ) 
(otherwise (retch ***S type instructions not handled*^ type))))) 
(chcck-f ixnum-Zargs ,• ops 
. , (selectq type 
Ino-operand 
' ( ( (f ixnu»-f ixnum) 

,(if f ixnuB-overf low 

'(goto , f ixnum-overf (ou) 
* (signal -error f ixnum-overf low) ) ) 
( (f ixnum-f Tonum) 
♦(if f loat-version 
Msequent iat 

;; get UPC straightened out 
(nop) 

(caM-and-return-to convert-f irst-f ixnum-to-f lonum .float-version)) 
(parallel (assign ari th-operat ion-index .index) 
(jump arith-binary-cal l-out))) ) 
{(f lonum-f f xnujsl 
, (cond (f toat-version 
* (sequential 

;; get UPC straightened out 
(nop) 

(cal l-and-return-to convert-f ixnu«-to-f lonu» .float-version))) 
( f I onuni- f i xnum-ver s i on 



'(goto , f lonum-f ixnufli-version) ) 
(t '(pa 



(t (para I iel (assign ari th-operat ion- index . index) 
(jump ari th-binary-cal !-out))))) 
( (f ixnum-extnum f lonun-extnum extnuri-extnum) 
(parallel (assign ar i th-operation-index .index) 
, , (jump ari th-binary-extnum-cal l-out) )) 
( (f [onum-f lonum) 
.(if f loat-version 

'(goto .float-version) 

'(parallel (assign ar i th-operatton-index .index) 
(jump ari th-binary-cal l-out)))) 
( (extnum-f ixnufii extnum-f lonum) 
(parallel (assign ari th-operat ion- index .index) 
(jump ari th-binary-cal l-out))))) 
(address-operand 
'((otherwise (parallel (trap-no-savo) 

(pushval address-operand) 
, . (junp ,no-operand-vcrsion))))) 

(s t qned- 1 mmed i ate-operand 
'dotherwise (parallel (trap-no-save) 

(pushva I «acro-s i gned- 1 imed i a to) 
(jump . no-operand-ver 8 i on) ))))))) ) 

;: Slower version, which can be used to save dispatches or because you cant use 
;; arithaetfc trap enable on the same cycle. Doesn't work unless uou have 
;: defucode ed at loc and not clear what to do with float-version 
(defnicro check-binary-ar i thmet ic-operands-slow 
(type index no-operand-veraion 
^optional float-version f ixnum-overf low) 
no-operand-ver s i on f i xnum-over f I ow 
(let (iops (selectq type 

(no-operand * (next-on-stack top-of-stack)) 
(address-operand '(address-operand top-of-stack)) 
(si gned- immediate-operand ' (top-of-stack-a nacro-si gned- immediate)) 
. (otherwise (retch "^,5 type instructions not handled* type))))) 
(check-f !xnum-2args .a ops 
(otherwise (seouent iat 

, (selectq type 

(no-operand nt 1 ) 

(address-operand ' (pushva I address-operand)) 
(sioned-inmediate-operand Mpushval macro-si gned- immediate))) 
, ( I f f loat-version 

'(assign ar i th-operat ion-f I oat ing-pc .float-version)) 
(paral iel 

(assign ari th-operat ion- index .index) 
.(if f ioat-vers ion 

• (jump ari th-binary-operand-dispatch-wt th-f loat) 
(jump arith-binary-extnuB-cal l-out)))))))) 
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;; Fast version of unary operation disDatchea 

;; Only for no-operand versions and address-versions 

Cdefmicro ch«ck-unary-arith>ietic-operat ion-fast 

(type index no-operand-version ^optional f toat-verston f txnum-overf lou) 
(let ((source (teiectq type 

(no-operand * top-of-etack-a) 
(addrees-operand 'address-operand) 

(othcrurse (retch "^S type instruct ions not handled" type))))) 
• (check-f iKnu»-larg-a , source 
* *(selectq type 
(no-operand 
' ( ( (f rxnum-f ixnum f ixnun-f lonu» f ixnu»-extnum) 
,(if f ixnum- over f low 

Mgoto , f ixnum-overf low) 
• (si anal -error f ixnum-overf lou))) 
( (f lonum-f Txnum f lonuoi-f ionua f tonum-extnuni) 
, (i f float-version 

•(goto , float-version) 

•(parallel (assign arith-operat ion- index .Index) 
(jump ar i th-unary-call-out) ) ) ) 
( (extnu»-f (xnu« extnu»-f ionuw extnum-extnum) 
(parallel (assign ar i th-operat ion- index .index) 
(jump ari th-unary-cal l-out))))} 
(address-operand 
•((othcruise (parallel (trap-no-save) 

(pushval address-operand) 

( j ump , no-operand- ver sion)))))))}) 

;;; Accessor ■icros for the current frame 

;The currently executing function 
(defato«icro frawe-funct ion 
(aaee (fra»e-po inter -X)}) 

;A fixnum full of various fields 
(dcfatowicro frame-* isc-data 
(anem (frame-pointer -2))) 

;Cal ler's return PC 
(defatowicro frame-return-pc 
(aaen (frame-pointer -3))) 

;Top of previous frame « value to restore to (stack-pointer) 
;The cdr code of this word is the value disposition 
(defatomicro frame-previous-top 
(a»ee (fraae-po inter *4})) 

;Base of previous frame • value to restore to (arg-pointer) 
(defatowicro frawe-previous- frame 
(a«en (fraae-po inter -5))) 

;Fields in frame-mi sc-data (these will alt be moved around later) 

(defatomic-byte-f icid frame-number -of-args fra«e-nuraber-of-args 

fratce-TOisc-data) 
(def atomic-byte-field frar.ie-c^eanup-bi ts fraae-cteanup-bi ts 

frame-mi sc-data) 
(de fa torn i c-by te- f i e i d frarae-buf for -under f I ou-b i t f rame-buf f er-under f I ow-b i t 

frame-mi sc-data) 
(defatoaic-byte-f ield frame-unsafe-reference-bit frane-unsafe-reference-bi t 

frame-mi sc-data) 
(defatoalc-byte-field frame-catch-bi t frame-catch-bit 

frame-mi sc-data) 
(defatoaic-byte-f ield frama-bindings-bi t frame-bindings-bit 

frame-mi sc-data) 
(defatoaic-byte-f ield frame- trace-b i t frame-trace-bit 

frame-mi sc-data) 
(defatoaic-byte-f ield frame-bottom-bit frarae-bottoa-bi t 

frame-mi sc-data) 
(defatoaic-byte-f ield first-part-dons frame-first-part-done 

frame-mi sc-data) 
(defatoaic-byte-f ield fran;e-lexpr-cal led fraae-lexpr-cal led 

frame-mi sc-data) 
(defatomic-byte-f ield frame-funcal led frame-funcal led 

frame-mi sc-dat3) 
(defatomic-byte-f ield frame- instance-ca! led frame-instance-cal led 

frame-mi sc-data) 
(def atoai c-by te-f i e I d f r ame-argLrrcent-f oraat frame-argument-f oraat 

frame-Bf sc-data) 

(assoc i ate-d i spatch-cues f rame-argutnent-f ornat »f rame-argument-f ormats*) 

jFtetds in status bits word for current stack group 
(defatomic-byte-f ield stacK-load-started cg-stack- toad-started 

Xcurrent-stack-group-status-bi ts) 
;?; Support micros for instructions 
:;; These are open-coded and go In one cycle 
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;Pu£h argument onto stack 
(defBiicro pushval (va!) 

'(parallel (assign (amem (stacit-pointep IJ) (»et-cdr ,vsl cdr-next)) 

(assign top-of-stack obus) 

(increment-stack-pointer) ) ) 

;Use top of stack as value and pop it 
;This uses up both the abu9 and the bbus 
(defmicro popvai 

•(parallel top-of-stack ;This is the data source w» return 

(assign top-of-stack (amem (stack-pointer -1))) 
(decreaent-stack-pointer) ) ) 

;Like pushval but replaces the top of stack rather than pushing 
(deffflicro newtop (val) 

'(parallel (assign (amem (stack-pointer 0)) («et-cdr ,v3l cdr-next) ) 
(assign tpp-of-stack obus))) 

;The value below top-of-stack 
(defatomicro next-on-stack 
(anen (stack-pointer -1))) 

;Top-of-stack on the A side 

(defatomicro top-of-stack-a 

(amem (stack-pointer 8))) 

:This is like doing tuo popvai 's and then a pushva! 

;I.e. it is how single-cycle two-operand instructions store their result 

(defnicro popZpush Tval) 

•(parallel (assign (awea (stack-pointer -1)) (set-cdr ,va! cdr-next>) 

(assign top-of-stack obus) 

(dccrewent-stack-potnter))) 

?Like pushval but doesn't smash the cdr code to cdr-next 
idefiBicro pushval-ui th-cdr (val) 

'(parallel (assign (amem (stack-pointer l))-,val) 

(assign top-of-stack obus) 

( incrcment-stack-pointer) ) ) 

(defmicro neutop-wi th-cdr (va! cdr) 

•(parallel (assign (amem (stack-pointer 0)) (set-cdr ,val tCdr)) 
(assign top-of-stack obus))) 

;Call subroutine defined in SUBPRIM, returns with data available in wemoru-data 
(defmicro memread (addr) 

•(parallel (assign vma »addr) 

(cat I memread) 

(declare-memory-timing active-cycle))) ;i.e. data-cycle when we return 

;Like memread but checks write access 
(defmicro memread-wr i te (addr) 
•(parallel (assign vma ,addr) 

(cal I nemread-wri te) 

(declare-memory-timing (next data-cycle) )) ) 

F:>1mach>ucode>UDCLS.LISP.22 

; -»- nodesLtsp; Base: 8; Lowercase: yes -*- 

; Load this into the compiler when compiling nicrocode 

(princ •#. (format nil •*.I;Loading LfOCLS (--A) . ' (namestring ftruenarae infiie))) 
«sgf i les) 

: Load the necessary support files 

(load 'sin) 
(load 'uu) 
(load 'check) 
(load *ut) 

(or (boundp '«»compi t ing-ua»*) (load 'ua)) 

imexpr defmicro-wrong-number-of-args) ; prevent undef fen warning 

(*lcxpr f intern) jIt's in UU 
(«jexpr paralyze) ;., 
(«lexpr retch) ;., 

; These are all the functions that can get called by UL-generated code 
; Prevent compi I er warnings for calling them 

(«expr set-pma-froB-vma pma-meTn-read pma-mem-wr i te simulate-transporter 

rot32 m3sk32 merge32 pc-readback pc-add rotate-pc-lef t rotate-pc-r ight 

instruct i on-s i gned- i mmedi ate i nstruct i on-uns i qned- i mraed i ate 

instruct ion-baseno instruction-offset instruct ion-opcode stack-address 

encode-ar i thmet i c-trap-cond i t i on over f I ow-p 

address-add-fp address-add-sp address-add-xo address-add-macrocode 

aref-amem aref-bmem sref-bmem-B aset-amem aset-bmem sset-bmem-0 

'®*^"E£ setq-vma setq-fp setq-ep i nc-sp dec-sp inc-praa inc-pc inc-»acro 

carryZS carryS^ IB-bit-sign-extend) 
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(fixnum {rot32 fixnum fixnum) (merge32 f'txnua ftxnua ftxnura) (mask32 frxnum) 
(pc-readback) (IG-bi t-sign-extend fixnum) 

(address-3dd-fp fixnum) taddress-add-sp fixnum) (addresa-add-xb fixnum) 
(addres9-add-»acrocode) (aref-a-Tien fixnum) (aref-bnem fixnum) (aref-bmem-0) } 

<notype (aset-amem fixnum fixnum) (aset-bmem fixnum fixnum) (aset-tfnemS fixnua) 
(setq-pc fixnum) (setq-vma fixnum) (setq-fp fixnum) {setq-sp fixnum) 
(carrySS fixnun fixnua fixnuc) (carry32 fixnum fixnum fixnum)) 

(special »frame-pointer» *stack-po inter* «xbas» «pc* «vma« «pm3* »(nstruction« 
Ka-memory« »b-memoru* «byte-r« *byte-s« xtgpe-cap* 
»mu 1 1 i p t y-x» «tnu 1 1 i p i y*y«} ) 

(«lexpr address-add) 

(princ ■ 

tLoading of UOCLS complete." msgfiles) 

(astatus feature Imucode) 
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-«- riodeiLiep; Package: nicro; Base. 8; Lowercase: yes -»- 
(c) Copyright 1982, Symbolics, Inc. 



; flicrocode assembler t linker for the hardware 



;;;; Definitions 

;There are two structures that represent siicrocode: 

; ■icrel — the "relocatable" representation that ta generated by 

; the microcode compiler and stored in files. 

; »rcabs — the "absolute" representation used in the linker, which 

; (inks complied files to make the final nernory image. 

; Bic — the shared part of those two structures (not instantiated by itself) 

(defstruct (mic :named :conc-na«e) 

(code «default-micro instruction*) ; 163-bit number (parity added later) 
Jtag nil) -NIL or symbolic tag for this instruction 

(load-time-patches nil) jFiefds to be fMfed in by FEP when loading 
(address-constraints nit) ;Humeric location it must go at, or UNIQUE, or list of Iocs 
(npc-Buccessor nit) ;Succes80r at .+1 

(naf-successor nil) ;Successor addressed via NAF 

(error- table nil) jArgs to signal -error, if any 

(defstruct (mi ere I : named : cone-name (: include mic)) 

(a-constant nil) ;AmeD and Bmem constants to be inserted, if any 

(b-constant ni I) 

(type-map nit)) ;Type map (slots arm assigned during linking) 

(defstruct (mi cabs : named : cone-name (: Include mic)) 

(predecessors nil) ;L(St of micabs's whose npc-successor is me 

(blocks nil) ;Ltst of address blocks that contain me 

(addresses nil) ;List of addresses actually stored at 

original -npc-successor -For intern-micrel 

original -naf-successor ;.. 

(multiplicity D) tNumber of micrel's turned into this micabs 

;A successor in a mi ere I is one of the following: 

; tnstr - a single successor 

; {SKIP true-instr false-instr) - a skip pair 

; (DISPATCH ((cue.) instr)...) - a dispatch block 

;An instr is either a sufrbolic tag or a mierel structure or NIL meaning drop-through 

Sdrop-through is on'y alloued in bKlP^ not in DISPATCH 

sAIso the two instr' s in a SKIP ma\^ be dispatch blocks (not supported at any level now') 

;Later the successor fields of a micabs are changed to something else... 

(def macro pushnew (item list) 

'(or (memq , i tern .list) (push , i tern .list))) 

;Associate from the code field to a list of micabs's, in order to merge those 

:with identical code, identical successors, and compatible other attributes 

(defvar «ir.iero instruction-hash-table* (make-array 27001)) ;Prime bigger than BK 

(defvar »microinstruct ion-tag-al i st«) 

(defvar «a-eonstant-haEh-tabTe» (make-equal -hash-table)) 

(defvar «a-constant-l i st*) 

(defvar «a-eonstant-address*) 

(def const «a-constant-start ing-address* 3000) ;0r whatever... 

(defconst *a-con3tant-end ing-address* 4000) 

(defvar *b-eonstant-hash-table* (make-equa I -hash-tab I e) ) 

(defvar *b-constant-l ist*) 

(defvar «b-constant-address*) 



I 
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defconst *b-constant-stapt ing-address* 10) 

def const »b-con8tant-ending-addre3s* 3G0) jLeave fast 103 locations for fticrocode 

There are also the a-iist <:a-meniory-vaIues«, »t3-aeoory-valucs» for initial ized variables 

defconst «microinstruction-*emoru-stze» 20088) ;SK 

defvar *rii cro instruct i on-mer;cjru»" (make-array «micP0instruction-Befflory-8ize«) ) 

defvar «addre8s-block-ha5h-tabTe* (maKe-equa I -hash-table)) 

defvar »address-block-l (St*) 

defvar «unresoi ved-symbol ic-references*) 

defvar *undef ined-tag-standin« nil) 

defvar *undef ined-opcode-standin* nil) 

defvar «speed-hi8tcgpaB» (nake-array 4)) 

Harduare parameters 

defconst «£kip-incremcnt» 10008) ;Btt 12 is the skip bit* and 0"true 
defconst *dlspatch-rncrement* 400) ;Bits 11-8 are the dispatch bits 
defconst *npc- increment* 1) jBits 7-0 are the fiPC increment bits 

defconst «npc-modulus« 400) 

This structure represents a block of instructions (possibly part iai ly-ful I) 
uhich must be stored together, i.e. with addresses equal except in certain bits. 

The structure is an array of the instructions, uith a leader. 
The size of the array is: 

2 - a skip pair 

20 - a dispatch block 

40 - a dispatch block of skip pairs 
For nou I give up trying to bs aore general! 

A block may have a successor, which is another block that nust bs stored 
in the consecutive address. Valid successor links are: 

2 -> 2 20 -> 40 43 -> 40 
because dispatch always takes an explicit address, but skipping doesn't. 
A 1 -> 2 I ink becomes a 2 -> 2- 

(defstruct (address-block :na«ed : array- leader sconc-naxe (:con8tructor make-address-block-internat ) ) 

;Do not regrind above tine into two—editor bug 
kind ?St(mbolic address-block krnd 

(successor nil) tBfock, if any, that ftust be at consecutive address 
(predecessor nil) :8locK, if any, in preceding consecutive address 
(wic-prectecessors nt I ) ;nicroinstruct ions that must precede this block (skip into it) 
(aliases nil) :B locks, if any, that this is inside of or equivalent to 

;Each element is actually a list (block offset) 
(locations nil) ;Base address list (noraally only one element) 
bit-aask) {Variable bits 

s;; Hardware Hi cro instruct ion Oaf ini ti one 

Special form for defining fle/ds in microinstruction word 
Oefconsts the name to be a byte pointer and also aats up tables 
to drive the translation from ptist format 

name - name of the field 

n-bi ts - width 

bits-over - rightmost bit number 

display-p - t if is to appear in disassembled instructions (if-eet «> only if non-default) 

default - default value for field (0 is the default default) 

indicator - how it appears in the plist form 

function - function to call when appears in plist form 

args = args to that function (after oic, value, and ppss) 

(def macro defu (name n-bits bits-over doptional display-p default indicator 
*. /, / . -, ... function &rest args) 

(let ((ppss (+ (Ish bits-over B) n-bits))) 
•(progn 'compi le 

(defconst ,name .ppss) 

,a(if display-p '((push** '(.(or indicator name) .ppss 

.•(if (eq display-p 'if-set) M, default))) 
«microinstruction-display-fields*})) 
••fit default '((setf (Idb ,ppss «defaul t-microinstruct ion*) .default))) 
,a{if indicator *((push** M, indicator .function .ppss .•args) 

«pl ist-to-*ic-table«))) 
.name))) 

(def macro push** (val field) 
'(let ((.val. .val)) 

(or (assq (car .val.) .field) 
(push .val. .field)))) 

(defconst *defaul t-microinstruct ion* 0) iChanged by defu' • below 
(defconst «microinstruct ion-di splay- f ie Ids* nil);.. 

{Translation from pltst fields to mic 

;Each entry is (indicator function byte-pointer . args) 

;The function is called with mic, field-value, byte-pointer, and the args. 

;Some fields are not in this table and are handled aa a special case, typically 

;uhen several fields must be processed together, 

;Some fields are not in this table because they aren't used at all at this level. 

(defconst *pl ist-to-mic-table* nil) ;Changed by defu's below 

(defu u-amra 12. t nil amem-rcad-addr store-amem-rcad-addr) 

(defu u-r-base 2 9 ni I 1) 

(defu u-r-offset 9 0) 

(defu u-amra-sel 2 12. t 3) {Default Abus source is frame-pointer 
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(defu u-xybus-9e! 1 14. t) 
idefu u-stKp-count 1 15. i f- 



(defu u-amua 12. 16. t) 
(defu u-amua-byte 10. IS.) 
(defu u-lbus-dev-addr 18. 
(defu u-w-tase 2 25.) 
(defu u-w-offset 9 16.) 
(defu u-anwa-10 1 26.) 
(defu u-amwa-11 1 27.) 
(defu u-amua-sel 2 28. t 3) 
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set 8 stack-pointer store-stack-pointer) 
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16. nil 1777 Ibus-dev-addr store- Ibus-dev-addr) 



{Default it not to urite Ame« (u-u-base<l> • 8) 



(defu u-eeq 2 38. if-set 0> 

(defu u-bmra 8 32. t ni t bmem-read-addp «tore-b»c»-addr) 

(defu u-bmwa 4 48. t 17 bmem-upi te-addr store-nuaber) 

(defu u-bmem-from-Kbue 1 44. t nil ur i te-bmen • tore-choice obus xbus) 

(defu u-nem 3 45. if-set 8 mem store-nem-f iaid) 

(defu u-spcc 5 48. if-eet 28 spec atore-choice 

ioad-byte-r toad-byte-e foad-stkp load-frmp 

load-xba9 foad-control load-speciat-aaps 

clear-stack-adjustment sload-inst on rev-2 dp 

•r i thmet i c-trap-enb trap- i f-type-cond 

trap- i f- type-cond-or-bbus-not- f i xnuw bu 1 1 i p I y-and- type-check 

crocks alub-eign-hack crocks-to-ybus aultiply 

28 addr-frow-abus inhibi t-page-ta98 dma 

address-phtc check-urite-access increment-inst Ifu-control 
•ri thmetic-trap-with-dispatch halt npc-magic auaken-task 
, ^ ^^ ur ite-task di sable-tasking 3B 37) 

u-magic 4 53. t nil magic store-number) 

u-cond-sei 5 57. t nil condition store-choice 

not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3 
type-condition bbus-not-f ixnum alub-8 ybus-31 
not-gc-conde>ined-tei»p not-gc-thie-stack not-gc-other-stack 
equal-pointer 

not-equal-f ixnuB not-equal-typed-pointer 
not-greater-pointer not-greater-f ixnuw-unsigned 
alu-31 sequence-break trace-flag-1 trace-flag-2 
not-lbus-dev-cond nc-cond 26 27 
38 31 not-ctos-ca«ie-from-ifu 33 
34 35 36 37) 
if-set 8) 



(defu 
(defu 



(defu 

(defu 
(defu 
(defu 



u-cond-f unc 
u-alu 4 64 



62. 
nil 



u-byte-func 2 88. 
u-obus-cdr 3 78. 



(defu 

(defu 



alu store-alu-func) 
if-set 8) 
nil force-obus<3S-34> store-choice 

«bus bbus bbus<7-6> ni I 8 1 2 3) 

:bbu3 doesn't work on rev-2 DP 
t nil force-obu8<33-32> store-choice 
abus bbus bbu9<5-4> nil 8 1 2 



u-obus-htype 3 73. 

u-obus- 1 type-eel 1 76. t l"force-obu8<3i-28> store-bl t~8T 



3) 



(defu u-cpc-se( 2 77. t) 
(defu u-npc-se! 1 79. tf-«et 1) 
(defu u-naf 14. 88. t) 

(defu u-specd 2 94. t 8 speed store-speed) jdefautt is fastest, just to aaxinizs 
defu u-type-«ap-se! 6 9d. if-set 8 typs-«ap store-type-map) 
(defu u-au-func 8 182. if-set 8) 
;(defu u-spare 1 110, if-set 8) 
;(6efu u-parity 1 ill. if-set 8) 

jNOTE: No knowledge of byte fields in the Microinstruction after this point! 
St;: Back end of compiler 



iossage! 



(defvar aopcode-offsets) 



I for 10-bit-iMediate-cperand expansion 



;Civen a name and a microinstruction plist, return the corresponding aicrel 
(defun assembte-mtcroinstruction-plist (name code y -<croi 

fi A ff-. ^ .X Aoptional address-conetraint «oocode-off«et«J 

(let ((default-cons-area working-storage-area)) ;Called inside macrl cxoansTon 
(let ((a.crel <assemble-microTnstruc!ion-pl istl code (list nane) 0))) expansion 
(and address-constraint 

(not (egnboip (mic-address-constrmints micrel))) :NIL or UNICrJE 
(setq address-constraint 

(append (if (atom address-constramt) 
(list address-constraint) 
address-cons tr a i nt ) 
(if (atom (mic-addrees-constraints micrel)) 
(list («ic-address-constraints micrel)) 
I—** r-- ^^ ("ic-address-constraints micrel))))) 

"^\i?.^~*'^^''***"^°"'*'*3'"*« aicrel) address-constraint) 
• 1 ere \ t ) t 

/5i^*^*''^ E?"*^ recursively on successors. Path and index are for generated taas 
(i^ectrtcarSide)'""*'"^^ (code path index ^optional Sve^tCIlfsSccesioH 

(microinstruction 
(let ((micret (make-micrel tag (cond ((pluep index) (append path (list index))) 

((cdr path) path) 
(t (car path))) 
arror-tab^e (gat code 'errcr-table) )) 
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(amua-in-use ni \ i 
(amua-ll-'m-use niO) 
;: Store the easy fields first so other things can cfobtjer over individual bits 
(loop for (indicator value) on (cdp code) by 'cddr 

do (store-field •icrel indicator value t)) 
(if (get code 'unique) 

(setf (mi c-acfdres3-constpaints aicrel) 'unique)) 
;; Now store the byte-funct ion 

(■ul t iple-value-bind (byte-func aagic Bagic-cask cond amua) 
(choose-byte-f unc-encoding code) 
(store-nujBber »tcrel byte-func u-bytc-func) 
(and aagic isetf (Idb u*Bagic (aic-code aicrel)) 

(logior (fogand (Idb u-aagic (nic-code aicrel)) 
(tognot aagic-aask)} 
aagic))) 
(and cond 

(store-number aicrel 

(if (eq cond *aacro) 

(Itth *opcode-off8et» 3) 
cond) 
u-cond-sel)) 
(uhen amua 

(setq amua-in-use t) 

(stcre-number mi ere I amua u-amua-byte))) 
;; Store the extended B-memory write address 
(let iitzua (get code 'bmem-wr i te-addr))> 
(uhen (and bmua (< bmua 388)) 
(setq amua-in-use t) 
(store-nuBber mi ere I bmua u-amua))) 

;Bit 10 is 0, so Aaea won't get written 
;; Other things that use AITUA 
(if (get code * tbus-dev-addr) 

(setq amua-in-use t)) 
(selectq (get code 'stack-pointer) 
((decrement) (setq amua-ll-in-use 0)) 
((increment) (setq amua-ll-in-use 1))) 
(selectq (get code 'ybus) 

( (ybu5-crocks-l) (setq amua-ll-in-use 0)) 
( (ybus-crock8-2) (setq amua-ll-in-use 1))) 
;; Store the a-memory write address wherever It belongt 
;s Put it in the a-memory read address if necessary 

;s This code had damned well better agree with check-spec-and-aagic-f ields 
(let ((amua (and (get code '«rfte-ame») (get code 'aaea-wr i t»-addr))) 
(amra (get code 'aaea-read-addr))) 
(cond ( (null amwa) 

;; Not writing, -except- if aemory aapped into Amea 
(if (fie I dp code 'amem-wri te-addr '(bus-address)) 
(store-amem-wri te-addr aicrel '(bus-address)))) 
((or (not (memq (get code 'abua) '(nil amea))) {Must use ATtUA 
(and amra (not (equal aawa amra))) jDitto 
(and (not amwa-in-use) jHay use ATUJA 

(or (not (atom amua)) |And no bit-11 conflict 

(not amua-1 1 - i n-use) 
(- (Ish amua -11.) amua-ll-in-use)))) 
(store-amem-wri te-addr aicrel amwa)) 

(store-amem-read-addr micrel amwa) ;nust use AflRA 
(store-number micrel 2 u-aawa-sel) 

(and (listp amua) ;nu8t crank up the speed 

(not (memq (get code 'speed) ' (slou-f iret-hal f very-slow))) 
,^ , (store-speed micrel 'slou-f irst-hat f u-speed) ))) ) 
;; if we re supposed to be uriting the Lbus, set the bit to tell 
;; the temporary memory control to do 1 t 
(and (get code write-Tbus) 

(eq awachine-version* 'proto) 
(store-number micrel 1 u-aBwa-10) ) 
;; Store bus sefect fields 
(if (or (fieldp code ' xbus 'bbus) (fleldp code 'ybus 'abus)) 

(store-number micrel 1 u-xybus-eeJ)} 
(let ((abus (get code 'abus)}} 
(sefectq abus 

((stack-pointer frame-pointer) 
(store-number micrel 3 u-amra-eel) 

(store-number aicrel (if (eq abus 'stack-pointer) 8 1) u-r-base)) 
I (memory-data) 
(store-number micrel 1 u-amra-sel) 
(store-number micrel 2 u-r-base) 
(store-number micrel 020 u-r-offset)) 
((memory-data-force lbus vma map pc) 
(store-number aicrel 3 u-amra-sel) 
(store-number micrel 2 u-r-base) 

(store-nuBber micrel (cdr (assq abus ' ((memory-data-force • 000) 

(lbus . 100) 
(vaa . 200) 
(aap • 300) 

*. *.>.! *P*= ' 400)))) 

, , ^ , . u-r-offs?t)))) 
(selectq (get code 'bbus) 

(aacro-unsigned-rmfflediate (store-number aicrel u-bmra) ) 

(macro-signed- immediate (store-number aicrel 4 u-bmra))) 
(selectQ (qet code 'L-busl 
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(ybus-cpocks-1 (store-numbar atcrel Bu-amua-lD) 
(ubu»-crocks-2 (store-numbsr cr/crel 1 y-aoua-lDU 
t; Set up cond func 
(store-number aicrel 

(cond ((get! code * (skip-true-sequence skip-false-sequence return-skip) ) 1) 
((■eirq "condi t ton-true (get code 'trap-enables)} 2) 
( («emq •condition-false (get code * trap-cnabtes) ) 3) 
(t 8)) 
u-cond-func) 
;; Seauencer controls 

(let (Icpc-sel 8) (npc-sei 1) (seq 8) (cpc-not-next nil)) 
(selcctq (get code * sequencer) 

((popj next-instruction) (setq cpc-sel 1 seq 3 cpc-not-next t)) 
((pushj pushj-return-dispatch) (setq seq 1 cpc-not-next t)) 
(pop (setq seq 3) ) 

(pop-npc (setq seq 3 npc-set 1)) ;8pec-func assumed 

(pop-npc-and-cpc-from-npc (setq seq 3 npc-sel 1 cpc-sel 2 cpc-not-next t)) 
(push-npc (setq seq 1)) 
(dismiss (setq seq 2)) 

(take-dispatch (setq cpc-sel 2 cpc-not-next t))) 
tx NPC comes from NEXT CPC+1 always, except when dispatching or popping into it 
(if (get code 'dispatch) (sotq npc-sel 8)) 
;: Now, the good part — the successor instructions 

(let* ((next (successor-instr (or (^et code "next-sequence) eventual-successor) 

path index ni 1)) 
(uust-be-naf -successor 

(or (successor-instr (get code * trap-sequence) path index *trap) 
(successor-dispatch (gat code *di6patch-tabte) path index) 
(successor-dispatch (get code 'ari th-trap-dispatch-table) path index) 



(and (or (fteldp code 'sequencer 'pushi) 

(freldp code 'sequencer 'pushj-ret 
(get code Mump-sequence)))) 



s turn-dispatch)) 
(get code 'jump-sequence)))) 
(skips (let T(true (get code 'skip-true-sequence) ) 

(false (get code * skip-fa I se-sequcnce))) 
(and (or true false) 
(list 'S<IP 

(if true (successor-instr true path index 'true next) 

next) 
(ff fatse (successor-instr false path index * false next) 
next)))i> 
(return-skips (let ((true (get code *return-true-sequence) ) 

(false (get code 'return-false-sequcnce))) 
(and (or true false) 
(list 'SKIP 

(if true 

(successor-instr true path index *true next) 
next) 
(if false 

(successor-instr false path index * false next) 
next)))))) 
;; Decide whether to put the skips in the NAF or the NPC 
(if skips 

(cond ( mu 3 t-be-naf -successor 

(setf (inic-npc-successor aicrel) skips) 
(setq cpc-sel 2) ) 
(t (setf (mic-naf-successor micrel) skips)))) 
(if must-be-naf-successor 

(setf (mic-naf-succecsor micrel) nust-be-naf-successor) ) 
:; Store the norma! successor (drop-through or jump or subroutine return) 
;; in NPC if it has to go there, or NAF if free to choose, or nowhere if 
;; not going to be used because next instruction reached via skip. 
;: Prefer the NAF over the NPC if neither is used to avoid introducing 
;; unnecessary address constraints. 

(and (cond (raturn-skips iReturn address is a pair 

(setf (aic-npc-successor ■icrel) return-skips) 
nil) 

((fteldp code 'ssquencer 'pushjj ;Need a return address aluaus 
(satf (■ic-npc-successor aicrel ) next) 
t) 
(skips nil) ?Skip substitutes for next 

(cpc-not-next nil) jNo successor required 

(iiust-be-naf-successor ;NAF in use for something else 

(setf (etc-npc-successor micrsl) next) 
(setq cpc-sel 2) 
t) 

(t ;Normal next address 

(setf (mic-naf-successor micrel) next) 
t)) 
;; Barf if drop through into nothing 
(nul I next) 

(not (fie I dp code 'spec 'halt)) ;sigh.... 
(not (get code ' error- tab ! e) ) ;a push] that nay^nr pcpj's 
(ferror nil "Drop into hyperspacs at ^t' (nic-tag micrel)))) 
(store-number mtcrel cpc-sel u-cpc-sel) 
(store-number micrel npc-sel u-npc-sel) 
(store-number micrel seq u-seq)) 
micrel)) 
(microsequenca 

(assemb I e-m i cro i nstruct i on-p 1 i stl 
■ (1 ink-microsequcnce-together (cdr code) eventual -successor) path index)) 
(othermsa (ferror n* I "Uhera did this alleged microcode come from?")))) 
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(defun I ink-«icposequence-together (I eventual-auccessor) 

(cond ((and (null (cdp I)) (null even tua I -successor ) } (car I)) 



((get (car !) 'next-sequence) 
(if (cdr I) (ferpor nit "Son 



- - "Something 'ts wrong, next-sequence inside a sequence")) 
(car I)) ;ju«p instead of drop-through 

(t (list* Bicroinstruct ion 'next-sequence 

(if (cdr i) (1 ink-mi croscquencs-together (cdr I) eventual-successor) 

eventua i -successor ) 
(cdar I))})) ;Can't use putprop— it*s destructive 

(defun successor- instr (instr path index tera ^optional eventual-auccessor) 
(cond ((atom instr) instr) ;NIL or a tag or a aic 

((nu! I ter«) 

(assenble-aicroinstruction-pl istl instr path (l-f index) eventua I -successor) ) 
( (zerop index) 
(assemble-Bicrotnstruction-pl istl instr (append path (list tern)) 

eventua I -successor) ) 
(t (asscmbIe-«icrotnstruction-p! istl instr (append path (list index ter«)) 

•ventua t -successor) ) ) ) 

;NOTE: For arith, the Abus can't be 3 because that would cause a type trap 
; however, the Bbus can be 3 since it isn't fully type-checKed. 
(def const *di spatch-cue-bi t-masks* 

(loop for (type cues) in M (ar i th (0 1 2 3 4 5 6 7 10 11 12 13)) 

(abus<2-0> (01234567)) 
(cdr-code (0123))) 
collect (cons type (loop for c in cues 

summing (Ish 1 c))))) 

(defun successor-dispatch (table path index) 
(and table 

(let ((valid-cues (or (cdr (assq (car table) »dispatch-cuo-bi t-masks*)) 177777)) 
(cues-seen (dispatch-table-cues-used (cdr table)))) 
(cons 'dispatch 

(loop for clause in (cdr table) 

collect (list (convert-dispatch-cues (car clause) valid-cues cues-seen) 
(successor- instr (cadr clause) path index (car clause)) 

(defun dispatch-table-cues-used (clauses) 
(loop for clause in clauses with res - 
unless (eq (car clause) 'otherwise) 
do (loop for cue in (car clause) 

do (setq res (logior ( I sh 1 cue) res))) 
finally (return res))) 

(defun convert-dispatch-cues (cues valid-cues cues-used) 
(if (eq cues 'otherwise) 

(loop for i from to 17 

unless (bit-test (tsh 1 i) cues-used) 
when (bit-test (Ish 1 i) valid-cues) 
col tect i ) 
(loop for cue in cues 

unless (bit-test (Ish 1 cue) valid-cues) 

do (ferror nil "^S invalid dispatch cue** cue)) 
cues) ) 

;0i8p!ay a microinstruction (a mic code) 
(defun disassemble-microinstructton (inst) 

(loop for (name ppss default) in «microinstruction-dl8plau-f ields* 
as val « (Idb ppss inst) 
unless (and default (- vat default)) 

do (format t "-^ ^A - -vQ" name va I ) ) ) __ 
.(defun store-field (mic indicator value doptional no-error &aux entru) 
icond (tsetq entry (aseq indicator »pIist-to-»ic-table*) ) 

(texpr-funcal I (cadr entry) mic value (cddr entry))) 
((not no-error) 
(ferror nil "l don't know how to store the -*S field" indicator)))) 

:Storing routines for particular f iefds/va/ues 

(defun store-number (mic value ppss) 
(setf (Idb ppss (mic-code ■icjj vafue)) 

(defun store-choice (mic value ppss irest choices} 
(setf (Idb ppss (mic-code mic)) 

(f ind-posi t ion-in-l ist value choices))) 

(defun store-bit (mic ignore ppss bit) 
(setf (idb ppss (mic-code nic)) bit)) 

(defun store-atu-func (mic value ppss) 

(store-number mic (or (f ind-posi t ion-in-ttst value normal-alu-funct ions) 
(f ind-position-in-l iet value weird-alu-functions) ) 



ppss)) 

(defun store- tupe-map (micrel map ignore) 
(setf (micrel-type-map micrel) map)) 

(defun store-stack-pointer (mic op enable-ppss) 
(setf (idb enable-ppss (mic-code mic)) 1) 
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<»tore-choice m'tc op u-amwa-Il * decrement *incre«ent)} 

(defun 8tope-ame!n-re3d-3ddr (■icrel addp ^optional ignore) 
(cond ((atom addr) 

(store-number •icret addr u-asra) 
(store-nusiber micpel 8 u-amra-»e)}) 
((eq (car addr) 'constant) 
(setf (micre l-a-constant nicre!) (cadr addr)) 
(store-number a icrel 8 u-arara-scD) 
{ (eq (car addr) 'macrocode) 
(store-number •icrel 2 u-amra-eel) 
(store-number «icrel 3 u-r-base) 
(store-number nicrel 488 u-r-offset)) 
{(eq (car addr) 'bus-address) 

(store-number ■Icrel 1 u-amra-sel)) 
(t (store-number micrel 2 u-amra-seJ) 

(store-number «icrei (f ind-posi t ion-in-Mst (car , addr) 

' (stacK'-pointer frame-pointer xbas)) 
u-r-baseJ 
(store-number mi ere I (logand (cadr addr) 377) u-r-offset)))) 

;This must not clobber the bits that are don't cares for this particular address 
;and also may be used for something else 

(defun store-amem-ur t te-addr (micre! addr Aoptional ignore) 
(cond ((atom addr) 

(store-number mi ere I addr u-amwa) 
(store-number micrel 8 u-amua-seD) 
((eq (car addr) 'macrocode) 
(store-number micrel 1 u-amua-sel) 
(store-number micrel 3 u-w-base) 
(store-number micrel 488 u-w-offset)) 
((eq (car addr) 'bus-address) 
(store-number micrel 3 u-amua-sef) 
(store-number micrel 1 u-amua-18)) 
(t (store-number micrel 1 u-amwa-sel) 

(store-number micrel (f ind-posi tion-in-l iat (car addr) 

'(stack-pointer frame-pointer Kbas)) 
u-u-base) 
(store-number micrel (logand (cadr addr) 377) u-M-of feet) ))) 

(defun store-bmsm-addr (mtcref addr ppss) 
(cond ( (atom addr) 

(store-number micre) addr ppss)) 
((eq (car addr) 'constant) 
(setf (micrel-b-constant micrel) (cadr addr))))) 

(defun 8tore-lbu5-dev-addr (micrel addr ppss) 
(cond (( I istp addr) 

(push Msymbol ic-tbus-stot , (car addr)) (m ic- I oad-ti ma-patches micrml)) 
(setq addr (cadr addr)))) 
(store-number micrel 

(if Inumberp addr) addr 

-(+ (cdr (assq addr ' ( (uri te-memory . 8) xproto only 
(ur i te-phta-and-asn . 1) 
(uri te-vma-and-pc . 2) ;tRic only 
(write- Iru-map . 4) 
(write-map-a • 5) 
(ur ite-map-b . S) 
(ur ite-both-maps ♦ 7)))) 
37.5)) 
ppss) ) 

(defun 5tore-meffi-f ield (micrel mem ppss) 

(store-number micrel 

(or (f ind-posi t ion-in-l ist mem 

(telectq semachine-version* 

(pro to '(nil continue ur ite-vma start-cycle)) 

{(tmc t«c5) '(nil microdavice start-read start-urite 

nil ur i ta-vfna blocK-read bi oc^^^-wr j to) ) ) ) 
(ferror nil ■*'S i Uegal value for jcem field" men)) 
ppss) ) 

(defun store-speed (micre! speed ppss) 
(store-number micrel 



(cdr (assq speed ' ((slou-f irst-hal f . 


2) 


(slou-second-half • 


1) 


(slou . 1) 




(very-clow . 3)))) 




ppss)) 




icroinstruct ion linker — outer module 





(de f un f I ush-m i crocode (mach i ne-ver s i on*) 

(setq »ucode-al ist-al ist» (dmiq (assq »machi ne-ver sion» »ucode-aI ist-at tst*) 

«ucode-al ist-ai i8t«) ) 
t) 

(defun I ink-the-mi crocode (*machi ne-ver sion») 

(clear-mic-tables) 

(format t "-ilNTERN-LOADED-mCRXDDE. ..") 

(loop for (name pi ist micrel) 
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in lor Ccdr Cassq *m3chm«-vers icn« '*uccde-at ist-a! i st«]') 

(ferror nil "*-S is not a losded DJcrocode program; - {-.S*"^, ^) exist" 
«mach i ne-ver s I on» 

(or (mapcar 'car «ucocie-ai ist-al i8t») '("none")))} 
do (intern-mi ere I aicrel)) 
(delist (phase '(resolve-symbolic-references deteraine-address-constraints 
ess i gn-f i xed-addresses 

determine-b 1 ock- successors determtne-other-successors 
assign-f loat ing-addresscs resolve-constants plug-in-successors) ) 
(fomat t "^-S..." phase) 
(funcal I phase) ) 
; Report un implemented instructions 
(toop for opcode from 9 to 1777 

as mic • (aref «microtnstruct ion-memory* (» opcode 4)) 

as name - (aref »opcode-table» opcode) 

when (and name (eq aic «undef ined-opcode-standir^) ) 

collect name into undef 
final Ig (cond (undef 

(format t "*^efined but untmplemented instruct ions; **% ") 
(farmat:print-list t "-^S" undef)))) 
; Check for overlappinq scratchpad memory assignments (because it's to ktudgey) 
(setq *a-memory-sym&oTs» (sort «a-memory-syfflbols« iSf* (lambda (x y) (< (cdr x) (cdr y))))) 
(setq *D-memory-sumbo(s« (sort «b-me:nory-sy[nbols« #' (lambda ix u) {< (cdr x) (cdr y))))) 
(loop for (sym , Tcci in »a-meTDory-sumbol 8» and prev ■ -1 then Toe and psyii -nil then sym 
uhen (< «a-constant-start ing-address* loc) 
when (< loc «a-con5tant-address») 

do (format t ***^The symbol -^-S overlaps the constants area of A-aemory" sym) 
when (« loc prev) 

do (format t "-^ASymboIs ^S and ^^S arc both defined at *0«A' ayn psy» loc)) 
(loop for (sym . loc) in «b-«emory-sumbols« and prev « -1 then loc and psyn - nil then syn 
when is *b-constant-star ting-address* loc) 
when (< loc *b-ccnst3nt-address») 

do (format t "^The symbol '^S overlaps the constants area of B*aeBory" syn) 
when (- loc prev) 

unless (and (memq syra »b-temp-symbols*) (memq psym *b-temp-symbols«) ) 

do (format t "^v^Symbols *S and *S are both defined at *'0«B sym psym loc)) 
(setq »need-to-l ink* nil)) 

(dcfun file-linker-report (pathname) 

(wi th-open-f i le (standard-output pathname 'rdirection 'toutput) 
( I inker-summary-repopt) 
(funcal i standard-output * : tyo tt\page) 
i 1 inker -de tat led-report) ) ) 

(defun 1 inker-summary-report 
t memory-usage-report) 
(loop with n-micabs « 

(loop for bucket being the array-elements of mi tcrotnstructton*hash- table* 
sum (length bucket)) 
for mtc bein^ the array-elements of «niicrotnstruct ion-*c«ory* 
when (null mic) sum 1 tnto n-free-locs, 

else when (eq mic xundef ined-tag-standin*) su* 1 into n-undsf-tags 
else when (eq mic *undef ined-opcode-standin*) sura 1 into n^undef-ops 
else sum (nicabs-mul t ipt ici ty nic) into n-nicrels 
and sum 1 into n-ni cabs- Iocs 
f ina! ly 
{format t "*0 microinstructions interned into -^ instructions stored in *0 locations. 
There are *D free locations, *^ undefined-tag halt instruct ions» and 
^ undefined-opcode halt instruct ions. -^ti** 

n-Rlcre!s n-mtcabs n-mi cabs- Joes n- free- foes n-undef-tags n-undef-ops) ) 
(loop for loc from 8 beiou *fticrotnatruct ton-wemory-size* 
when (null (aref *microinstruct fon-Rieniory* loc)) 
count (and (zerop Oogancf toe *Ekip-increment«) ) 

(nu/i (aref xmicroinstruct ion-memory* (+ loc »aKrp-incre*ent*) ) )) 
into n-free-skips 
and when (zerop (logand (* 17 *dispatch- increment*) loc)) 

count (loop repeat 20 for loc from loc by «dispatch- increment* 
always (null (aref *aicro instruct ion-memory* loc))) 
into n-free-dispatches 
finally (format t "There are ^'U free skip blocks (out of 4096)'^ 
and »^ free dispatch blocks (out of 512). ^X" 
n-free-skips n- free-dispatches) ) 
(format t "Number of microinstructions with speed") 
(dotimea (i 4) 

(format t "-vVT^- (+ 48. (* i 8) ) i)) 
(terpri) 
(dotimes (i 4) 

(forffat t "-VT^D" (+ 40. (* i 8)) (aref *speed-histogram* i))) 
(terpri)) 

(defun linker-detailed-report () 

(for*at t "*tLocations of microcode routines* first »lcroinstruct ionst^-rt") 
Cforaat t "'^dA '^A*2X*' "Sumbor "Locations") 

(loop for (tag . aic) in Tsortcar (copul f •! *»icroinstruct ion-tag-«l ist*) ISf'str ina-Iesso) 
do (format t "-^0A " tag) • i* h 

(formatter int-! ist t "*5,*e0" («i cabs-addresses «ic) " * "-m41X") 
(terpri )) 
(format t "-vUt^har inq of separate but identical microinstructions in source coder^^Zt") 
(format t *^QA -vA-^ZX' "Representative tag" "Multiplicity from sourcs") 
(loop for (tag . mul t) 

in (sort (loop for bucket being the array-elements 

of Jf!»icro instruct ion-hash-table* 



4,887,235 
145 146 

nconc (loop for »ic in bucket 

uhen (> (fticabs-nuttipl ict ty kic) 1) 
collect (cons (mic-tag aic) 

(aicabs-multiplicrty Bic)}}) 
r (lambda (x y) 

lor (> (cdp x) (cdr u) ) 

(and (• (cdp x) Tcdr y)) 

(alphalessp (car x) (car y))})}} 
do (format t "-^SA -^-.t" tag muit)) 
(format t "«r I -on icro Instruct ions that had to be ttored in more than one cmem iocat ton:*2S'*) 
(format t *^QA *'A^2X** "Representative tag* "Multiplicity in control memory") 
( loop for (tag » muf t) 

in (sort (loop for bucket being the array-elements 

of »»i cro instruct ion-hash-tab I e» 
nconc (loop for mic in bucket 

when icddr (micabs-addresses mtc) ) 
collect (cons (mic-tag mic) 

(length (micabs-addresses ■ic))))) 
If* (lambda (x y) 

(or (> (cdr x) (cdr u>) 

(and (- (cdr x) Tcdr y)) 

(alphalessp (car x) (car y)))))) 
do (format t "^QA ^-O-vf tag nultM 
(format t "*|--XContro I -memory fflap:>^22;^18A-.3SA'»18A-^A*2X" 

"Location" "ftepresentatfve tag" "Uocation" "Representative tag") 
(loop for mic being the array-eiements of «microtnstruction-memory» 
using (index Ice) with phase • ni I 
unless (nut I mtc) 

unless (eq mic »undef ined-opcode-8tandin«) do 
(format t "*S,'eO *A" loc (mic-tag mic)) 
(i f phase (terpr i> 

(let* ((curcol (+ 7 (flatc (mic-tag mic)))) 
(destcol (max (+ curcol 1) 45.)) 
(ntabs (// (- (logior destcol 7) curcol) 8))) 
( loop repeat ntabs 

do (funcati standard-output *:tyo#\tab)) 
(loop repeat (\ (if (zerop ntabs) (- destcol curcoi) destcol) 8) 
do (funcati standard-output 'rtyo l(\sp)))) 
(seta phase (not phase)) 
finally (if phase (terpr I)))) 

(defun menory-usage-report () 

(send standard-output ':fresh-Mne) 

(if (boundp *»a-constant-address*) ;L(riker has been run 

(format t "A-aessory locations -O-'vO used for constants i^ end of constants area)'*t" 
ma-constant-start tng-addresB* ^1- »a-constant-address») 
(1- «a-constant-ending-cddress«))) 
(format t "A-memory locations") 
(repor t-a-b-memory- 1 ocat i ons ma-meBcry-symbo 1 9*) 
(format t " used for var iables-vX") 
(if (boundp '♦b-constant-address*) jL inker has been run 

(format t "B-memory locations *0— vQ used for constants (^ end of constants area)^t" 
mb-constant-atart tng-address* (1- mb-constant-addressm) 
(1- *b-constant-ending-address«) >l 
(format t "B-memory locations") 
(repor t-a-b-memory- 1 ocat t ons *b-mefacry-symbo I s«) 
(format t " used for variables-'X'') 

(format t "Type-map locations 8--^ used (77 end of type map)-*!" 
(1- (length »type-maps«)))) 

(defun repor t-a-b-memory- I ocat ions (I) 
(setq I (sort (mapcar tf'cdr I) t$*<)) 
i I oop uh t I e I 

as loc - (pop I) 
as old! m toe 
for n upfrom 1 
do (cond ({« n 6) 

(setq n 8) 

(send standard-output ' : tyo tt\cr) 
(send standard-output ' : tyo ^\tab))) 
(format t " -^l" loc) 
( loop uhi te I 

while (or (- (car I) toe) (- (car I) (1+ loc))) 
do (setq loc (pop I ) ) ) 
(or {m loc old!) 

(format t "-*C" loc)))) 
;;:; fit cro instruct ion linker — intern, attlgn constants 

(defun clear-mic-tabtes 

(copy-array-portion stmicroinstruct ion-hash-tsblem 8 8 jFill with NIL 
mm i cro instruct ion-hash-tab I em 8 

(array-length «microinstruct ion-hash- table*) ) 
(copy-array-portion mm i cro instruct ion-memory* 8 8 ;Fin with NIL 

*mtcrotnstruct ion-memory* 8 (array-length «mi cro ins true t ion-memory*) ) 
(cirhash-equal ma-constant-hash-table*) » y « ««u y»w 

(setq ma-constant-adaress* «a-constant-start ing-address*) 
(c 1 rhash-equa 1 *b-const ant-hash- tab 1 e*) 

(setq «b-constant-address* *b-constant-starting-address*) 
(dotimes (i 4) 

(aset 8 mspeed-histogram* i)) 
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(c I phash-equa I »address-b I ock-hash-tab i e*) 

(aetq »addPcss-btocK-l i st* nil) 

(setq *»icrotn3truct ion-tag-al ist* n't I)) 

; — Uould also clear type sap assignments, but would break simulator 

:Given a nicrel return a micabs, the canonical representative of all micrels to 
;be stored in the sane location as it. This also does constant assignment, 
(defun intern-micrel (nlcrel) 
(let {(code (mic-code micre!))) 
(if (micrel-a-constant micrel) 

(setf (Idb u-amra code) (locate-a-constant (micrel-a-constant micrel )))) 
(if (micrel-b-constant micrel) 

(setf (Idb u-bmra code) ( locate-b-conetant (micreUb-constant micrel)))) 
(if (micrel -type-map micrel) 

(setf ( tdb u-type-map-sel code) (assign- type-map (micret-type-map micrel)))) 

{defined in UL 
(let ((ans (let ((hash (\ code (array- fength mmicroinstruction-hash-table*)))) 
(loop ^or candidate In Taref mmicroinstruction-hash-tablc* hash) 
when (and <- (mic-code candidate) code) 

(compatible-tags (mic-tag candidate) (mic-tag micrel)) 
(equa 1 (mi c- 1 oad-t i me-patches cand i date) 

(mic- load- time-patches micrel)) 
(compatible-address-constraints 

(mic-address-constraints candidate) 
(mic-address-constraints micrel)) 
(equa I -successor (micabs-or iginal-npc-successor candidate) 

(mic-npc-successor micrel)) 
(equa I -successor (micabs-or iginaUnaf-successor candidate) 

(mic-naf-successor micrel)) 
(compatible-error-table-cntries (mic-error-table candidate) 

(mic-crror-table micrel))) 
do (incf (mi cabs-mul tip I icity candidate)) and 
return (merge-tags-and-address-constraints candidate micrel) 
final I y 

(let ((mi cabs (make-micabs code code tag (mic-tag micrel) 
error- table (mic-error-table micrel) 
load-time-patches (mic-Ioad-time-patches micrel) 
address-constraints (mic-address-constraints micrel) 
npc-successor 

(intern-successor (mic-npc-successor micrel ) ) 
or i g i na 1 -npc-successor (m i c-npc-successor m i ere I ) 
naf-successor 

(intern-successor (mic-naf-euccessor micrel)) 
or iginal-naf-Guccessor (mic-naf-successor micrel) )) ) 
(push mi cabs iarei mmicro instruct ion-hash-table* hash)) 
(incf (aref *speed-histogram» lldb u-speed code))) 
(return micabs) ) ) ) ) ) 
(if (symbolp (mic-tag ans)) ;i,e« not a generated tag 

(push (cons (mic-tag ans) ans) mmicroinstruction-tag-alistm)) 
ans))) 

(defun intern-successor (succ) 

(cond ((suTTboip succ) succ) jNIL or a tag 

((atom succ) (intern-micrel succ)) sa micrel 
((eq (car succ) 'skip) 

(mapcar ^* intern-successor succ)) 
((eq (car succ) 'dispatch) 
(cons 'dispatch 

(loop for (cues ntc) in (cdr succ) 

collect (list cues (intern-successor mic))))) 
(t (ferror nil "Hey! Uho turned out the lights?")))) 

?A1I generated tags are compatible with each other, user doesn't care 
(defun compatible-tags (tl t2) 
(or (eo tl t2) 

(tistp tl) 

(iistp 12))) 

(defun compat ibie-addrcss-constraints (cl c2) 
(cond ((eq cl 'unique) nil) 
( (cq c2 'unique) nil) 
((nul 1 cl) t) 
((nul i c2) t) 

((atom cl) (if (atom c2) (equal cl c2) (member cl c2))) 
((atom c2) (member c2 cl ) ) 
((< (length cl) (length c2) ) (loop for c in cl always (member c c2))) 

.JlJ'°°P ^o*" c in c2 always (member c cl))))) 

(defun merge- tags-and-address-constralrts (into from) 
(Imt ((cl (mic-address-constraints into)) 
(c2 (mic-address-constraints from) ) ) 
(cond ((nul I c2) ) 

((null cl) (setf (mic-address-constraints into) c2)) 
(t (l3t {(con (if (atom cl) (list cl) cl))) 

(if (atom c2) (or (member c2 cl) (push c2 cl)) 
(loop for c in c2 

unless (fflembcr c cl) 
do (push c cl) ) ) 
(setf (mic-address-constraints into) 

(if (null (cdr con)) (car con) con)))))) 
(and llistp (mic-taq into)) 
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(op (not (listp (mic-tag fpor))) 

(better-tag (mic-tag from} (mic-tag into))) 
(«etf (nic-tag into) (mc-tag from))) 
(«etf («ic-error-table into) 

(■crge-error-table-entpies (mic-errop-table into) 

(»ic-eppop-tab!e from))) 
into) 

(defun bettep-tag (tagl taQ2) 

(cond ((< (length tagl) (length tag2) ) t) 

((> (length tagl) (length tagZ)) nil) 

(t (< (string-length (cap tagl)) (stping-length (cap tag2)))))) 

(defun egual-succcssop (si «2) 
(cond ((atoni si) (eq si s2)} 
{(atoin s2) ni I) 
((neq (car si) (car s2)) nil) 
((eq (cap el) ^skip) 
(and (equal -successop (cadp «1) (cadp «2)) (equal -successor (caddp si) (caddp 62)))) 
((eq (cap si) dispatch) 
(loop fop clausel in (cdp si) and clause2 in (cdp s2) 
always (and (equal (cap ctausel) (cap ciause2)) 

(equal -successop (cadp clausel) (cadp clau8e2)))) ))) 

(defun locate-a-constant (value) 
(if (numbepp value) 

(setq value (togand (mask 36.) value))) 
(cond ( (gethash-equal value »a-constant-hash-t3bIe») ) 
(t (let ((pes «a-constant-addpess*)) 

(if (- ♦a-constant-addpess* »a-constant-ending-addpe5s*) 

(feppop nil "A-wemopy constants apea ovepfiou")) 
(incf ^a-constant-address*? 

(puthash-equal value pes »a-con8tant-hash-table») 
pes)))) 

(defun locate-b-constant (value) 
(if (numbepp value) 

(setq value (logand (mask 34.) value))) 
(cond ((gethash-equal value «b-constant-hash-table«)) 
(t (let ((pes *b-con3tant-addpe5s«)) 

(if (- «b-constant-addpessiit sb-conatant-endtng-addpess*) 

(feppop nil "B-«cmory constants apea ovepflow")) 
(incf *b-constant-addpess*) 

(puthash-equal value pes »b-con»tant-hash-table«) 
res)))) 
j:;; flicpoinstpuction Linkep — fix up after interning everything 

jGo thpough and pepiace tags and drop-throughs with bIcs 
(defun resoIve-synboMc-pefapences () 

(setq *undef ined-tag-standin* (fiake-wicabs tag *undef ined-tao-standin) ) 
(stope-fteld »undef med- tag-stand in* 'spec 'halt) 
(setq «unpesol ved-SL|irboI tc-pefercncec* nil) 

(loop fop bucketbetng the array-eiements of «icrotnstPuct son-hash- tab fe« do 
(loop fop »ic in bucket do 
(setf (mic-npc-successop aic) 

(pesolve-symbol Jc-successop Bic (aic-npc-successop aic) nil)) 
(setf (mic-naf-successor mic) 

(pesolve-symbol tc-successop ■ic («ic-naf-8uccesaop mic) (mic-npc-successop mic))) 

(cond (»unpesolved-sumbol ic-pefepences« 

(fopmat t "*^The following microcode poutines wepe rcfepenced -*» 

but don*t seem defined:*) 
(delist (x *unpesolved-syrabo! ic-pefepences«) 
(fopmat t "^ ^5 pefepenced by " (cap x)) 
(fopmat:ppint-! ist t "^^S" (cdr x)) 
(fopmat t -*«''))))) 

(defun resolve-symbol rc-successorl (mic succ dpop-thpouah) 
(cond ( (nul I succ) 

(op dpop-thpough 

(cerpop t nil nil "drop-through successor to *S, but nothing there'" 
»* / . .. (mic-tag mic)))) 
It (resolve-symbol I c-successor mic succ drop-through)))} 

(defun resolve-symbof ic-8uccessop (mic succ dPop-thPouah) 
(cond ((nul! succ) ni H >- » 

((symbolp succ) 
(op (cdp iassq succ «»icPoinstpuction-tag-al ist*) ) 

(let ((elem (assq succ *unpesolved-symbol ic-pefepcnces*))) 

OP elem (push (setq elem (neons succ)) «unresolved-symbol ic-rcferences«) ) 
(push (mic-tag mtc) (cdr elem?) 
«undef i ned- tag-stand in*))) 
((atom succ) succ) ;A micabs 

( (eq (cap succ) 'skip) 
•(skip , (pesolve-symbol ic-successopl mic (cadP succ) dpop-through) 

, (reso ve-symbol ic-successorl mic (caddr succ) drop- through) ) ) 
((eq (car succ) dispatch) 
•(dispatch 
. ,(locp fop (cues mtc2) in (cdP succ) 

collect '(.cues , (pesoive-symbol tc-successopl mic mic2 nil))))})) 
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;;;; flicroinstpuction linKer — deterBina address constraints 

(defun wake-address-block (kind &aux length mank block) 
(seiectq kind 

(skip (setg length 2 wask »9k ip-incpcment*) ) 

(dispatch (setq length 20 mask (* 17 *df spatch-increment*) ) ) 

(dispatch-skip (setq lenath A0 cask (+ (« 17 *di spatch- increment*) *sktp-increment») ) ) 

(otherwise (ferror nil "fluh?"))) 
(setq block (aake-address-b lock- interna I kind kind :«ake-arrau (: length lenath))) 
(setf (address-block-di t-raask block) cask) 
(push block «address-btock-list») 
block) 

(defun intern-address-block (kind atist) 

(seta air St (sortcar alist #*<)) ;Canonical ordering 

(or (gethash-equal alist «address-b lock-hash- table*) 
(let ((block (Mke-address-block kind))) 

(puthash-egual alist block *address-b lock-hash-table*) 
(loop fcr (pos . aic) in alist 

do (store-into-block nic block pos)) 
block))) 

(defun store- into-b lock (»ic block pos) 
(aset nic block pos) 
(pushnew block (■) cabs-blocks aic))) 

;Convert the successors that are blocks fro» the list-structure form used 
M^.^^^^^l^ *? *^® address-block defstruct. Also create predecessor back-links, 
(defun deteraine-address-constraints 

(loop for bucket being the array-elements of «aicro instruct ion-hash- table* do 
(loop for mic in bucket do 

(setf (mic-npc-succcssor aic) (convert-successor (mic-npc-succsssor nic) «ic)) 
(setf (Bic-naf-successor aic) (convert-successor (Bic-naf-successor aic) nil))))) 

(defun convert-successor (succ predecessor) 
(cond ((atom succ) ;NIL, a tag. or a Bicabs 

(and succ predecessor 

(pushnew predecessor (a i cabs-predecessors succ))) 
succ) 

( (eq (car succ) *8kip) 
(let ((block (intern-address-block *8kip 

(list (cons 8 (cadr succ)) 
... _. , (cons 1 (caddr succ)))))) 

uf predecessor (pushnew predecessor (address-block-aic-predecessors block))) 
b 1 ock) ) 
((eq (car succ) 'dispatch) 
(if predecessor (ferror nil "read unhappy Baknam")) 
(intern-address-bfock 'dispatch 

(loop for (cues aic) in (cdr succ) nconc 
Hoop for cue in cues 
,^ ,^ .. .., , .. collect (cons cue mic))))) 
(t (ferror ml 'Hey! Uho turned out the lights?")))) 

:Nou that all of the blocks have been made, determine their successor relations. 
;ihis may Bake new blocks, since unlike mice each block is only stored in one place* 

;First pass: find all npc (consecutive address) relations between blocks. 
; 10 avoid complications we always make new blocks to act as successors, but 
; mark them as aliases of the old blocks so that later we can only instantiate 
; one copy» if possible. 
(defun de term ine-b lock-successors 
;; This loop repeats until no new address blocks are created 
(loop for a i ready-done -nit then prev ious-address-bl ock- i ist 
as previous-address-block-list • xaddress-block-l ist* 
until (eq «address-block-l tst* already-done) 

do ;; This loop does each address block that was not done before 
(loop for St - *address-block-list* then (cdr Ist) until (eq Ist already-done) 
as block - (car Ist) 

;; Does any aic in this block have an npc successor? 
as npc-successors-exj St - 

(loop for mic being the array-elements of biock 

thereis (and mic ftypep (»ic-npc-succe8Sor aic) 'Bicabs))) 
as skip-successors-exist » 

(loop for aic befng the array-elements of block 

thereis (and mic (typep (aic-npc-successor aic) *address-block))) 
as kind « (address-block-kind block) 

when (or npc-successors-exist skip-successors-exist) do 
(let ((succ (make-address-block 

(if (and skip-successors-exist (eq kind 'dispatch)) 
*diEpatch-skip kind)))) 
(setf (address-block-predecessor succ) block) 
(setf (address-block-successor block) bucc) 

(loop for mic being the array-slements of block using (index dos) 
with skip-step - (if (eq kind 'skip) 1 28) 
as sued - (and mic (mic-npc-successor mic)) 
when (typep sued 'Bicabs) 

do (store-into-block sued succ pos) 
else when (typep cued 'address-block) 
do (push (list succ (\ pos skip-step)) 
(address-bloek-al iases sued)) 
(loop for sued being the array-elements of sued 
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and pos upfroi (\ pos skip-step) by skip-step 
do (stope-into-b(ock sued succ pos))))))) 

tSecond pass — find blocks with npc-predecessop aics that are not in blocks 
; and consequently weren't seen In the first pass. Also find blocks with 
; component Biics with npc^predecessor mics* In either case we create a new 
; block and make it the predecessor of ths found block. In the first case 
; this completes the data structure that tet(5 us what size and shape hole 
; we need to find in control ■e«ory; in the second case it avoids unnecessarily 
; Making two copies of a nic. 

; However, if the alternative to «aktng two copies of a wic is to create a chain 
; of 5 skip blocks in a row, which cannot be located when we have 8K control 
; memory» then we would rather duplicate the »ic. 
(defun datermine-other-Buccessors O 
;; This loop repeats until no new address blocks are created 
(loop for already-done « ni I then previous-address-block-i ist 
as previous-address-block-l tst ■ «address-block-l i st« 
unti I (eq *address-block-l ist» already-done) 

do ;; This loop does each address block that was not done before 
(loop for 1st - «address-block-l ist* then (cdr 1st) until (eq let already-done) 
as block m (car Ist) 

as chain-length - (loop as b - block then (address-block-successor b) 

wh i I e b 

while (eq (address-block-kind b) 'skip) 
count t) 
as block-predecessors • 

(loop for mic in (address-block-»tc-predecessors block) 
when (and (null (ni cabs-blocks Kic)) 

(symbolp (aic-address-constraints aic))) ;NIL or Uf^IQUE 
unless (aeffl^ »ic res) 
co! iect »ic into res 
finally (return res)) 
as other-predecessors - 

(loop for nic being the array-elements of block 
unless (nui I nic) 

nconc (loop for nic in (micabs-predecessors «ic) 

when (sumbotp (mic-address-constraints aic) ) 
when T< (+ (max-predecessor-cha in- length aic) 
chain- length) 
5) 
unless (siemc; nic res) 
col lect aic) 
into res 
final ly (return res)) 
as predb « (address-b lock-predecessor block) 
with slot do 
t — I'm fairly sure that I don't need to worry about aliases here 
' Uhat we want to do is first store alt the block-predecessors then 
fill in the available gaps with other-predecessors. However the 
other-predecessors have stronger address requirements. So we will 
first do the block-predecessors, which may leave one location left 
over for other-predecessors. After that, fill in any available holee 
with other-predecessors, or create a new predecessor block, 
[loop for mic in block-predecessors do 
;; Find a place to put this predecessor, by force if necessary 
(loop doing (multiple-value (predb block) 

(make-address-block-predecessor block predb)) 
until (loop for pos from 8 below (array- length predb) 
when (null (aref predb posf) 
return (setg elot pos)) 
do (setq predb nil)) ;This predb used up, make new one 
(store- into-b lock mic predb slot)) 

If a predecessor exists, and free slots fortuitously exist in the right 
places, fill them with the other-predecessors. If no predecessor exists, 
and there are other-predecessors, it can't hurt (much!) CsicJ to make one. 
(cond (other-predecessors 

(mu 1 1 i p t e-va I ue (predb b I ock) 

(make-address-block-predecessor block predb)) 
(loop for mic in other-predecessors 

as target ■ (mic-npc-successor mic) 

when (loop for succ being the array-elements of block using (index pos) 
there ie (and (eq succ target) 

(null (aref predb (setq -slot pos))))) 
do (store-into-block mic predb slot))))))) ^ 

;ttake a block to preceed the given block, if necessary. 

;If the second argument /s non-NIL (we already have a predecessor available), 
; then don't make a new one, except if this block is already located, in which 
s case we make a conu of it and a nrf*riprf»««nr nf fh» rnnti. Thig jg necessaru 

. , -^ . the block already 

;has a predecessor, make a copy of the block so that a second predecessor can exist, 
; luo values: the preceding and succeeding blocks, 
(defun make-address-block-predecessor (block ppcdb) 
(prog () 

(if (if (nul I predb) 

(address-block-predecessor block) 
(or (address-b I ock- locations block) 
(return predb block))) 
(setq block (copy-address-block block))) 
(let {(predb (make-address-block (address-block-kind block)))) 
ise.t (address-biock-successor predb) block) 
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(setf (address-bloci^-predecesaor block) predb) 
(return (values predD block))))) 

;Cop^ a block (and its successors) uhen space preceding the block is overcrouded 
(defun copy-address-block (block 4aux new) 

(setq new (mai'-e-address-block (address-b lock-kind block))) 

(push (list new Q) (address-block-al iascs block)) 

(loop for mic being the array-elements of block using (index pos) 

do (store-into-b(ock vnc new pos)) 
(cond ( laddres5-b lock-successor btock) 

(setq block (copu-addreas-btock (address-block-successor block))) 
(setf (address-bTock-predecessor block) new) 
(setf (address-block-successor new) block))) 
new) 

(defun wax-predecessor-cha in- length (mic) 
(let ( (preds (micabs-predecessors mic))) 

(if (null preds) 1 ;This test is unnecessary in the old loop by coincidence 
(1+ (loop for Die in preds ;and superfluous in the new 

max i « i ze (wax-pre decessor *cha i n- 1 ength mic) ) ) ) ) ) 

;;;; tlicro instruct ion linker — address assignnent — 

(defun assign-f ixed-addresses 

(setq *undef ined-opcode-8tandin« (nake-micabs tag '♦undef ined-opcode-standin*)) 
(store-field »undef ined-opcode-standin* 'spec 'halt) 
;: Store halts in the dispatch locations for all undefined opcodes 
;; and all defined but unlmpfemented opcodes 

(loop with ucode-afist » (cdr (assq ^machine- vers ion* »ucode-a) ist-al ist») ) 
for t from 8 to 1777 -.Opcode dispatch 

unless (and (- i 376) <cq «machine-yer8ion* 'proto)) ;no-oper3nd-subdispatch 
unless (assq (aref «opcode-table« i) ucode-alist) 

do (aset «undef ined-opcode-standin* «micro instruct ion-memory* (leh i 2))) 
;; Store any microinstructions that have no freedom of location at all 
(loop for bucket being the array-elements of »micro instruct ion-hash- table* do 
(loop for mic in bucket 
as con - (mic-address-constraints mic) 
do (cond ((numberp con) (locate-inst mic con)) 

((jistpcon) (delist (loccon) (locate-inst mic loc)))))) 
;; Now go fill m any unused reserved locations with a halt instruction 
;: so that no floating instructions wilt float into them 
(selectq «machine-version* 
(proto 
(store-default-inst 10088 *undef ined-opcode-standin«) ;Transport trao 
(loop for 1 from 10018 to 10015 ; Type trap (4 Iocs), map miss (2 Iocs) 

do (store-defaul t-inst i «undef med-opcode-standin*)) 
(loop for i from 10820 to 10822 ;IFU exceptions? 
,,, do (store-defaut t-inst i *undef ined-opcode-standin*) ) ) 
((tec tmc5) 



(loop for mem-state from 8 to 30 by 18 do 
(loop for i in * (0 1 4 5 6 7) do 



(store-defaul t-mstdogior 10300 me»-8tate i) »undef ined-opcode-standin*) ) ) 
(store-defaul t-inst 14000 «undef ined-opcode-standin*) ;IFU traps 
(store-default-inst 15000 «undef ined-opcode-standIn*)} 
(otherutse iierror nil "What are the trap addresses for -^S?" mmachine-version*) ) ) ) 

(defun assign-f ioattng-addressee (&aux (freep 0)) 
;; Now pack the address biocks into available free spaces 
(assign-address-b)ocks) 

;; Now pack npc-chains of instructions not involving any blocks 
(ass I gn-npc-chai ns) 

;; Now assign any remaining instructions arbitrarily 

(loop for bucket being the array-elements of *microjnstruction-hash-table* do 
(loop for mic in bucket 

do (setq freep (assign-f loat ing-mic nic freep)))) 
( t f scunreso I ved-synbo i i c-ref erences* 

(setq freep (assrgn-f loat ing-mic »undef ined-tag-standin* freep)))) 

(defun assign-f loating-mic (mic freep) 
(or (micabs-addresses mic) 
(locate-inst ric 

(loop until (null (aref »micro instruct ion-memory* freep)) 
do (incf freep) 

(if (2 freep *raicroin5truction-memory-size«) 

(terror nil "Gleep! Microinstruction memory overflow")) 
finally (return freep)))) 
freep) 

(defun locate-inst (mic loc &aux tem) 

(cond ((null (setq tern (aref «microfnstruct ion-memory* loc))) 
(aset mic »microinstruct ion-memory* Joc) 
(push- loc (micabs-addresses nic)) 

•/. ^^\^ " somebody's predecessor, he is now absolutely constrained, 
(let ((succ (mic-npc-successor mic))) 
(cond ((typep succ 'micabs) 

(locate-inst eucc (npc-next-loc foe))) 
((typep succ 'address-block) 
(locate-address-block succ 

(logand f npc-next-loc loc) 

(lognot laddress-block-bit-mask suet)))))))) 
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({neq tem mic) 
(f error nil "Two different fftcro instruct ions truing to go in same location;** 
-S and -S- 
(nic-tag mic) (mic-tag ten))))) 

;Note that this does not remember the location nor link to euccessore 
;U8e this only for •*fake'' mic'a 
(defun store-defaui t-inst (loc mic) 

(or (aref tmicroinstruct i on-meniory* loc) 

(aset 11 ic »«icro instruct ion-memory* loc))) 

(defun npc-next-loc .(loc) 

(+ (» (// loc «npc-modulus*) «npc-fnoduIus«) 
(\ (+ loc «npc- increment*) »npc-modulu5*) ) ) 

;I don't really want to solve the general bin-packing problem, so I guess I ui M 
'i"5\>*'*'^'^ *^® largest blocks first, and assign down from the top of memory, 
;ana hope for the best. Doesn't fill holes in big blocks uith little blocks! 
' M * '^.""'y sure this is going to have to done over in a cleverer uau 

*iM I ^^'''.'t seems to work, doesn't it.... 
Idefjn assign-aOdress-blocks 
:; Largest blocks first. But only blocks w ithout predecessors, and not 

;; unnecessary duplicate aliases, need be located. 

(loop for block in (sort (loop for block in *address-block-l let* 

when (and (null (address-biock-predecessor block)) 
(null (address-block-al iases block)) 
(null (address-block-locations block))) 
coi tcct block) 
r(laff.bda (bl b2) 

(> (addrcss-block-stre bl) (address-biock-size b2))}) 
with disp-freep • (- *m icro instruct ton-memory-si zc* (« 17 «di spatch- increment*) ) 
with skip-freep • (- »»icroinstruct ion-mei.iory-size» «skip-increfflent») 
when (eq (address-block-kind block) 'ekip) 

do (setq skip-freep (f ind-space-for-blcck block skip-freep)) 

else do (setq disp-freep (f ind-space-for-block block disp-freep)))) 

(defun address-block-size (block) 
(i f (address-block-successor block) 

U (array-length block) (address-block-size (address-block-successor block))) 
(array-length btock))) 

(defun f ind-space-for-biock (block freep) 
(do ((b block (address-block-successor b)) 

(bits 8 (logior (addrcss-block-bi t-mask b) bits)) 
(width 9 (max (arrcu- length b) width)) 
(lenqth 8 (1+ length))) 
((null b) 
(decf freep length) 
(loop when (minusp freep) 

do (error 'mtcroinstruct ion-»emory-overf tow 

•:msg (format nil "Cannot locate chain of ^ blocks" length) 
' :chain-head block) 
until (loop repeat length for pos upfrom freep 

always (loop fcr pos upfrom pos by (to^and bits (- bits)) 

repeat width ; skip/dispatch bits are adjacent! 
always (null (aref »a icro ins true ticn-Bemoru* pos) ))) 
do (decf freep)) 
(locate-address-block block freep) 
freep))) 

;Locate ail of the instructions in this address block, based on loc 
;Note that an address-block can get located twice, if it is an npc-successor 
;of two mic* 8 both with fixed address constraints, 
(defun iocate-address-block (btock loc) 
(push I oc (address-b I ock- 1 ocat i ons b I ock) ) 
(loop for mic being the array-elements of block 

as pos upfrom loc by (if (eq (address-block-kind block) 'skip) 

«sk i p- i ncrement* *d i spatch- i ncrement*) 
unless (nul I mic) 

do (Ioc3te-inst mic pos)) 
(i f (address-b lock-successor block) 

( I ocate-address-b 1 ock (address-b I ock-succcssor b I ock) (npc-next- I oc I oc) ) ) ) 

;Find all microinstruction chains that must be in consecutive addresses 
jand a'-e not already located (none of them are in blocks and the head of 
: the chain is not assigned to a fixed address). Find places in memory 
; to stuff then, 
(defun assign-npc-chains 
;; This loop iterates over all unlocated chain hoads^ longest chains first 
(loop for (length . mic) 

in (sortcar (loop for bucket being the array-elements 

of wiicroinstruction-hash-table* 
nconc (loop for mic in bucket 

when (and (null (mi cabs-addresses mic)) 

(null (micabs-prcdecessors mic)) 
(typep (mic-npc-successor mic' 'micabs)) 
collect (cons (mic-npc-chain-length mic) mic))) 
#•>) 
wi th freep ■ 8 

do (locate-inst mic (setq freep (f ind-space-for-chain freep length mic))) 
(incf freep length))) 
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(defun mic-npc-chain-iength (mtc) 

(I cop for Clio - mic then (rtic-npc-suooe^sor ate) unti ! (null mic) 
count t)) 

(defun f ind-space-for-chain (freep length mic) 
(loop uith oiccK-start • nil 

for freep upfrom freep by 1 

uhen (a freep «microinstruct ion-mfimory-size*) 
do (error mi cro instruct ion-rremory-overf iow 

*:flicg (format nil "Can't locate *0-entpy IPC chain of nicpoinetruct tone" 

length) 
';chain-head mic) 
uhen (null (aref «Tnicroinctruct ion-iie«opy» f peep) ) 

do (cond ((null block-start) (setq biock-start fpeep)) 

((zerop (ionand 377 freep)) (setq block-stapt fpcep)) 
^ ((- (- (1^- freep) block-start) length) (petupn blocK-st2Pt) ) ) 
else do (setq block-start nit))) 

;A der^uoging function 

(de^un print'Chain (mi c-or-btock) ; or nil 
ttur.ccase mic-or-olocR 
ip I cabs 

(foriat t "-^IIC: *A" (»ic-tag mic-op-blocK)) 
(print-chain (nic-npc-successop bic-op -block) )) 
(addpcss-block 

(foPMt t "-&^A-BL0CKt-C3: " 

laddress-block-kind »ic-op-block) (array-icngth nic-or-block)) 
(forBat:print-l ist standapd-output "^A" 

(loop fop mic being the appay-elements of «ic-op-block 
collect (if mic (»tc-tag mic) "-"))) 
(print-chain (addpees-block-successop ■ic-or-block))))) 

(def flavor microinstpuct ion-memopy-ovcpf lou (msg chain-head) (eppop) 

: ini tab I e* instance- var iab les) 

(defwethod (micro) nstruct f on-memory-overf iou ;repopt) (stream) 

(format stream "Gleep! Hi cro instruct 1 on memory overf tou^X^A'^XThe chain is:^^" asg) 
(let ((standard-output stream) 
ipr inlength nt I ) ) 
(print-chain chain-head))) 

(compi le-f lavop-nethods microinstruct ion-memory-overf lou) 
;;;; riicpo instruct ton linker — plug in successor addresses 

(defun plug-in-successors 

<Ioop for toe fpom be lou «ti«tcroin8truction-»emoru-size* uith succ 
as mic ■ (aref «»icp0instpuct icn-memopy« loc) 
unless (nul I mic) 

do (if (setq succ (mic-naf-successop mic)) 

(stope-number mic (get-mic-or-block-addpcss succ) u-naf)) 
(if (setq succ (mic-npc-successor ■icJ) 
(cond ({typep succ ^micabs) 

top (eq (apef itrnicroinstruction-memopy* (npc-next- ioc loc)) succ) 
(feppop nil "^S^s npc-successor isn't thepe!" (raic-tag mic)))) 
((typep succ 'address-block) 
(or (address-block-effectively-at 
succ 
(logand (npc-next-foc loc) 

( 1 ognot (addrcss-b i ock-b i t-mask succ) ) ) ) 
(ferrop nil "^S's npc-successop isn't thepel" (mic-tag mic)))))))) 

(defun get-fflic-op-block-addpess (x) 

icond ((typep x 'mi cabs) (cap (micabs-raddpeoses x) ) ) 
((typep X 'address-block) 
(or (car (adbres»-b lock-iocat i ons x) ) 

(let ((alias (caar (address-block-aiiases x)))) 
(+ {get-fflfc-cr-block-address ai ias) 
(* (cadar (address-block-aliases x) ) 

( logand (address-block-bi t-mask al ias) 

(- (address-bi ock-b it-mask alias)))))))))) 

(defun address-block-ef feet ive tu-at (block loc) 
(or (memq loc (address-block-Tocat ions block)) 

(loop for (b offset) in (address-block-aliases block) 
therejs (address-block-effectively-at b 

(+ {« offset (logand (address-block-bi t-mask b) 

(- (address-block-bi t-mask b)))) 
loc))))) 

(defun resolve-constants 

(setq «a-constant-l ist* (pesolve-constantsl *a-constant-hash-table«) ) 
(setq «b-con5tant-nst* (rcsol ve-constantsl *b-constant-hash-table») )) 

(defun resol ve-constnntsl (hash-tabte) 
(local-declare ( (special constants)) 
(let ( (constants nil ) ) 

(■aphash-equai <^' (lambda (val loc) 
(push (cons loc 
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(cond ((nunibepp vai) val) 

((and (listp vai) (eq (car val) 'but Id-task-state)) 

(resolve-task-state (cdr vat))) 
(t if&rror "^S ri legal constant" val)))) 
constants) ) 
hash- tab f el 
constants) )) 

(defun resolve- task-state (options) 
(let ((cpc nil) (npc nil) (csp 17)) 

(loop for (opt val) on options by 'cddr do 
(seiectg opt 

(cpc (sctq cpc (resolve-cmem-locat ion val))) 
(npc (setq npc (resotve-cnen- location val))) 
(csp (setq csp val ) ) 

(otheruise (terror "-^S illegal in BUILD-TASK-STATE" opt)))) 
(or cpc (terror "CPC not specified in -^S" (cons 'bui id-task-state options))) 
(or npc (setq npc (dpb (I* cpc) 8013 cpc))) 
(dpb csp 3424 (dpb npc 1616 cpc)))) 

(defun resolve-cmefn- location (loc &aux niic) 
(cond ((symbolp loc) 

(if (setq mic (cdr (assq loc *microinstruct ion-tag-at ist«) ) ). 
(car (nicabs-addresses mic)) 
(foreat error-output "-^AUAnNING: *S not found for bui Id-task-state-^t" loc) 
8)) 
((nurrberp loc) loc) 
' ( (and ( I i stp loc) ieq (car foe) "npc-successor) ) 
(setq loc Cresolve-CBie»- location (cadr loc))) 
(dpb (1+ loc) 891B ioc)) 
(t (terror ***S it legal cmem-locat ion for build-task-state" loc)))) 
;;;; File interface 

(defun ne«-»(crocode-ver8ion .^,p,P^«^«,^,.,., 

(let ((•i:«8ystem-being-Badc» (»i : f ind-9v«*e»""3ned "niCROCuDE") > 
(8i:«si lent-p* nil)) 
(si : increment-compi led-version-1) 
(si: increaent-loaded-version-l) ) ) 

. So»eday these «ight be a tlAICE-SYSTEn transforaation 

(defun coBpi le-the-»icrocode (*inachine-ver8ion«) 
(ur i te-the-«icrocode «ni3chine-version* t)) 

(defun wr I te-the-«icrocode («JTiachine-version* 

^optional (link-p nit) 

(name (string-append smachine-version* "-MIC")) 
(version (si zget-system-version "niCROCODE") ) ) 
ior (boundp * I cold: xmost -negative- imnedi a te-number«) 

(Icoldtsetup-cruciai-var iables nil)) 
(let ((patnnaae (f8:«iake-pathnatne ':host "SYS" *:directory "L-UCODE" 

*:naffle name 't vers ion version))) 
(ui th-open-f t le (log (funcail pathname •:neu-typ8 "LOG") '(iprint)) 
(let ((standard-output i»ake-bro3dcast-stream log standard-output)) ) 
(if tink-p (I ink-the-utcrocode «machine-version«) ) 

;; Write out various files 

(ur i te-mic-f i le (funcalt pathname *: new- type 'niC) name version) 

(wr i te-sym-f i le (funcail pathname 'tneu-type "SYH") name version) 

(wri te-err-f i le (funcail pathnsma 'mew-type "ERR") na«e version))))) 

(defun wr i te-»ic-f i le (pathname name version) 

(ui th-open-f i le (stream pathname ' (rout rfixnum)) 
(let* ((length (rein (string- length name) 32.)) 

(naraelB (make-array (// (1+ length) 2) 'ttype 'art-lBb *:di8placed-to name))) 
(funcail stream ' : tyo length) 
(funcail stream *: string-out namelB)) 
(funcail stream ':tyo version) 

;; Type map 

(let ((ntypes (Ish (length «tupe-maps*) G))) 

(format t "-^Type map - *€ locations" ntypes) 

(funcail stream ' : tyo 1) 

(funcail stream *:tyo 0) 

(funcail stream ' ; tyo ntypes) 

(funcail stream * : tyo 1) 

(loop tor i from below ntypes 

do (funcail stream *:tyo (aref «type-nap» t)))) 

:; A and B memor ies 

(ur i te-a-b-memcry stream 2 «a-fflemory-value6» «a-constant-l ist* "A") 

(ur i te-a-b-Bienory stream 3 *b-memory-value8« vb-constant-l ist* "B") 

; i Control memory 

(loop uith length ■ (array-act ive- length »aicroin8truction-memory«) 

uith total - with patches 

for start from 8 below lennth 

as mic • (aref «microinstruct ion-menory« start) 

do (cond ( (nul I mic) ) 

((null (cetq patches (mic-load-time-patches mic))) 
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(let (Icount (loop for address from start belou length 

as inic • (aref *ffiicroin8truction-ne«ory« address) 
uh! le (not (nul I uic)) 
while (null iaic-load-t i»e-patches mic)) 
sum 1))) 
(tncf total count) 
(funcall ctpeam *:tyo 4} 
(funcali stream ' : tyo start) 
(funcalt stream * ! tyo count) 
(funcall stream ':tyo 7) 
( loop repeat count 

for address from start 

as mic • (aref »microinstruction-remory« address) 

when (not (nul I mic)) 

do (loop with vai • (nic-code mic) 

repeat 7 for ppss from 8320 by 2800 
do (funcall strean 'ityo (Idb ppss vai)))) 
(incf start (1- count)))) 
(t 

;; Ur i te cmem location that needs to be patched: 
;; 104 <address> <n-patches> 7 raw-ctnem-data patches. •. 
;: 1 6-bytes-of-name — store slot number of card into U AnUA<3:5> 
(incf total 1) 
(funcall stream * : tyo 184) 
(funcall stream ':tyo start) 
(funcali stream ' : tyo (length patches)) 
(funcal I s-ream * : tuo 7) 
(loop uith vai - (mc-code mic) 

repeat 7 for ppss from 8023 by 2080 
do (funcall stream *:tyo (idb ppss vai))) 
I loop for (type arg) in patches do 
(seiectq type 

(symbol ic-t bus-slot 
(funcall stream ' : tyo 1) 
(let ((name (stri no-append (string arg) * •))) 

(funcall stream '^:tyo (dpb (aref name 1) 1810 (aref na«e 0))) 
(funcall stream ':tyo (dpb (aref name 3) 1018 (aref name 2))) 
(funcall stream *:tyo (dpb (aref name 5) 1013 (aref name 4))))) 
(otheruiso (ferror "•^C unknown load-time patch tune" tupe)))))) 
finally (foraat t "*AC men - ^ locations" total)) 

(funcall streaa 'rtyo 0))) jttark EOF 

(defun wri te-sym-f i le (pathname name version) 
(with-open-f t le (stream pathname '(rout)) 
(pkg-bind "niCRO" 
(Tet ((base SJ) 

(format stream "i;; -*-node:Lisp;Base!S-«--.t (VERSION ^S '^.)*X" name version) 
(funcall stream *: string-out " 
/(A-nEHORY ^ 

•) 

(delist (elen «a-«emory-symbois») 
(funcall stream ' : tyo #\sp) 
(prinl eiem stream) 



(funcall stream ' : tuo tf\cr)) 
(funcall stream ': string-out ") 



■) 

(funcalt stream ':8tring-out " 
/(B-nEHORY 
•} 

(delist (el em «b-memory-symbols«) 
(funcall stream ' s tyo U\sp) 
ipr'ml eleo stream) 
(funcall stream ':tyo #\cr)) 
(funcall strea* *:strtng-out ") 

(funcall stream '; string-out " 
/(C-HEnORY ^ 

■) 

(delist (elem *microinstruct ion-tag-al ist*) 
(funcall stream 'ityo #\sp) 

(prinl (cons (car elem) (mi cabs-addresses (cdr elem))) stream) 
(funcall stream * : tyo #\cr)) 
(loop for mic being the array-elements of JWaicroinstruction-memcru* 
using (index address) 
when (not (nul I mic) ) 
do (let ((name (mic-tag mic))) 

(cond ((and name (not (assq name wiicroinstruction-tag-al ist*))) 
(funcall stream * : tyo ;;^\Bp) 
(prinl (list name address) stream) 



■))))) 



(funcall stream * : tyo #\cr) ) ) ) ) 
(funcall stream 'tstring-out ") 



(defun ur i te-err-f i le (pathname name version) 
(ui th-open-f i le (stream pathname M:out)) 
(pkq-bind "niCRQ" 
(let ((base 8)) 
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(format stream "t;; -«-node:Li spj Base: 8-*-*X (VERSION -^S 'vO.)*X" nane version) 
(funcati stream : string-out " 
/(ERROR- TABLE 
•) 

(loop for mic being the array-elements of »»icrotnstruction-»emory« 
using (index address) 

when ate do (let iierr (mic-error-table Biic))) 
Ccond (err 

(funcat! strean •ttyo tf\sp} 
(prinl (cons address err) stream) 
(funcall streaa 'rtyo #\cr))))) 
(funcall stream 'istring-out ")"))))) 

(defun wr i te-a-b-memory (stream memory fixed-values constant- I ist name) 
(let ((mem-data (append fixed-vaiuea constant- I ist nil))) 
(setq mem-data (sortcar mem-data * <U 

(format t '*^&-A memory - *0 iocations" nama (length •em-data)) 
(loop uhiie mem-data 

as start « (caar mem-data) 

at count * (loop for address from start 

for (loc • val) in mem-data 
uhi le (• loc address) 
sum 1) 
do (funcsM stream * : tyo memory) 
(funcall stream ' : two start) 
(funcall stream * : tyo count) 

(funcall stream * : tyo 2) ;36-bits worth 
( loop repeat count 

as val « (cdar mem-data) 

do (loop repeat 3 for ppss from 0^23 by 20C8 

do (funcall stream * : tuo (Idb ppss val))) 
(pop mem-data))))) 



F:>LMach>Ucode>SYSDCL,LISP.64 

;;; -«- Mode: Lisp: Package:Uscr; Baserfi; Louercasetyes -»- 
;;; (c) Copyright 19&2, Symbolics, Inc. 

; System declaration for L-machine microcode compiler, simulator, and code 

(package-declare micro global 4088) 

;The microcode system consists of the compiler and the microcode, I'd like 
; to be able to say that ail transf ormat rcns on tr.e microcode depend on having 
;the compiler loaded, but there doesn* t appear to be a reasonable way to say that, 
; (make-system microcoapt Icr) can ce dene fcanually when necessary. 

(detsystem micro 

(: pathname-default "SYS: L-LfCOOE;") 

; (: package flicro) 

(: component-systems microcompi (er microcode)) 

(defsustem microcompi 1 er 

(tpithname-default "SYS: L-UCOOE;") 

(:mcdule zwei CZUET) :package "Zwei") 

(:mcdjle simulator ("SIH^)) 

(:inodule compi lerl CUU" "CHECJf" "UL")) 

(! module coicpi ler2 ("UH")) 

(:noduic simulator2 ("SinX")) 

(:mcdulc architecture-macros CUA" "OIX")) 

(:ncdul« archi tecture-def s ("L-SYS; SYSDEF" "L-SYS; SYSDFl") 
jpackage "flicro") 

(rmodule instruct ion-defs ("L-SYS: OPDEF") :packaae "Hicro") 

(: module epr inter ("BETTER-SFRINT^R") ) ^ ^ 

(:module make-system CnA^trSfS"}) 

(:compi le-load aake-systeia} 

(jcosipi I e- load zwei) 

(:ccmpi le-load simulator) 

(:ccr.pi le-load cospiierl (:fasload simulator ■ake-system)) 

(:cospr te-!oad compi ier2 (: fas load simulator ccmpllerl make-system)) 

ureadftle instruct ion-defs (rfasload simulator ccmpilerD) 

(:re2df lie archi tecture-def s ((:fasioad simulator coj.piierl) (:readfile instruction-defs)) ) 

i: CDffip I le- lead stmulatcrZ 

(pfasload simulator compilerl) (rreadfile archi tecture-def s instruction-defs)) 
((rfasload sirrulator cc?rpilerl) (:readfile archi tecture-defs instruction-defs))) 

Ccompi le-load architecture-macros ((rfasload simulator conipilerl 8ifflulator2) 

(:re3dfile archi tecture-defs instruction-defs)) 

I (: fas load simulator compilerl simulator2) 

f.rnrnu. i^^M -^ -^* M (:rcadfile archi tecture-defs instruction-defs))) 

I ; compile- load sprinter)) 

;Transformat ions for microcode 

;nA)CE-SY5TEM isn't as general as it Might be, to we need different transformations 

;for each machine. 

;Transfor«ation« for prototype eactiine (no Memory control) 
(S(:def ine-s imp I e- transformation :proto-«icro-l03d 

«icro:proto-fasload-l si : f i le-ncwer-than-iastal led-p (*PROTD-niCREL*) NIL 

("Load prototype microcode" "Loading prototype ffiicrocode** 
•loaded prototype microcode") 

NIL) 
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(si :def tne-8 imp ie- trans format ion !proto-«icro-co«pi Is 

■licrorproto-compi fe-f i !e-l ai : f i le-newer-than-f i le-p CLISP") CPROTO-IIICREL") 
CCompite prototype microcode** "Compiling prototype Bicpocode" 
"■cofflpiled prototype •tcpocode") 

(defaacro (:proto-«icro-compi le-load si tdefsystew-fiacro) (input ioptionai com-dep load-dep 
4/^. .^/.. ... cdm-cond load-cond) 

(:proto-Bicpo-I03d (:ppoto-aicro-conipi le .input ,com-dep ,cora-cond) 
♦load-dep , load-cond)) 
(defmacro (:ppoto-Bicpo-compt le-load-ini t si :defsysteffl-macpo) (input add-dep 

^optional con-dep load-dep 
- ^ ^ ^. iaux function) 

(setq function 

( I e t -c 1 sed ((si: «add i t i ona I -dependen t -«odu I es« 
. . (sl:papse-nodule-components add-dep si:«8U8te»-being-def ined*))) 
8 1 : comp 1 1 e- 1 oad- i n i t-cond i t i on) ) 
•(:ppoto-micpo-load {:proto-micpo-compi le .input ,co«-dep .function) Joad-dep)) 

;Tpansfopmations fop tf2 »achine (tempopapy aemopy control) 

(sirdef ine-simple-tpansfopmat ion : tiic-tnicpo-load 

■icpo:tmc-fasload-l 5i:f » le-newep-than-instal led-p (•TMC-niCREL") NIL 
("Load TfIC Bicpocode" "Loading TflC fcicpocoda" "loaded THC •icpocode") 

(8i:def ine-simple-tpansfopmat ion ; tmc-micpo-coBpi le 

«icro:tmc-compi ie-f i le-1 si : f i le-newep-than-f i le-p ("LISP") CTnC-niCFEL") 
(Compile mC »icrocode" "CoinplMng TMC Bicpocode^ "compiled TtlC Bicpocode") 

(defmacpo (: toc-Bicpo-compi le-lcad si rdefsysteB-aacpo) (input «opti ona ( coB-dep load-dep 
,/* ._,. ... coB-cond load-cond) 

(: toc-Bicpo-load (; tmc-micpo-compi le .input ,coB-dep ,com-cond) 
,load-dsp , load-cond)) 
(defraacpo (: tBc-Bicro-compi le-load-ini t si :def systeB-aacPo) (input add-dep 

^optional con-dep load-dep 
, ^ ^ ,. Aaux function) 

(setq function 

(let-closed ((s(i*addi tional -dependent-modules* 

. . (sirpapse-ffodule-components add-dep stxssysteB-being-def ined«) ) ) 
si:compi le-load-ini t-cond i tion)) 
* (: tac-Bicpo-load (; tmc-»icPo-compi le .input .coB-dep .function) , load-dep)) 

;Tr3nsfopmat ions fop pev-5 tempoPapy meniopy contpol 

(8i:aef ine-simple-tpansfopmat ion : tmc5-micpo-load 

micro: tmc|-fasload-l si: f i le-newep-than-installed-p ("TnCS-riCREL") NIL 
(Load TnCS Bicpocode" "Loading TflCS Bicpocode" "loaded THCS Bicrocode") 

(si :def ine-simple-tpansfopfflation : tmc5-micpo-compi le 

Bicro:tmc5-conpi le-file-l si : f i le-neuep-than-f i le-p ("LISP") ("TnCS-PIICREL") 
(Compile TnCB Bicpccode" "Compiling TttCB Bicrocode" "coopiied THCS Bicpocode") 

(defaacpo (: tBcS-micro-compi le-load •i:def8ysteB-B3cro) (input ^optional coB-dep load-dep 

•/.♦-«c .• . - f X r - .. . coB-cond load-cond) 

i: tmcb-micpo-load (: tmcb-mtcpo-compi le .input .coB-dep ,com-cond) 
. . ^ / f- , load-dep , load-cond)) 
tdefmacpo (: tmcb-Bicpo-compi le-load-ini t 8i:defsysteB-Bacro) (input add-dep 

^optional com-dep load-dep 
/. . , ^. Aaux function) 

(setq function 

(I e t-c t oscd ((si: «add i t i ona I -dependen t-modu I es« 

<9i-*pa"se-moduJe-components add-dep 8i;»»y8teB-betng-def ined«) ) ) 
s I : ccnp I 1 e- 1 oad- i n ( t-cond 1 1 i en) ) 
(:tmcb-micPD-load (: tmcS-micpo-compi le , input .co»-dep .function) , load-dep)) 

:Tpanafopmat}ons for ppoduction machine (memopy contPol with IFU) 

is*:def ine-simple-tpansformation : ) fu-micro-load 

?iP'^°i''fr".^^?'°^^"^ 8i:file-neuer-than-installed-p ("IFU-HICREL") NIL 
NIL? microcode" "Loading IFU Bicrocode" "loaded IFU Bicrocode") 

(si:def ine-simpte-transformation : i fu-micro-compi le 

micros J fu-compl le-fi Ie-1 st : f i t e-neuer-than-f i te-p ("LISP") ("IFU-tllCREL") 
l^Lompile IFU microcode" "Compiling IFU Bicrocode^ "compiled IFU Bicpocode") 

(defmacro (: i fu-micro-compi le- toad si idefsystsB-macro) (input ^optional com-dep load-dep 

M:ifu-micro-load (= i fu-micro-compi le .input .com-dep .com-cond) """""' load-cond) 
rrto*^,^^ / w ♦ load-dep , load-cond)) 
idefmacro (: i fu-m.cro-compi le-load-ini t si :def system-macro) (input add-dep 

&op 1 1 ona I com-dep t oad-dep 
(setq function *3"** function) 

1 1 e t -c i osed ((si: .add i t i ona t -dependen t-modu I es* 

18 1 :parse-modijJ!fc-components add-dep si :»system-being-def ined*) ) ) 
M.;*.. ^*'*-^?"'Pi'?-!oac*-'n't-condition)) 
l.ifu-m.cro-load (: i fu-micro-compi (e .input .coB^dep .function) .load-dep)) 
;Transformations for simulator 
(SI : defme-s imp I e-transformat ion tsim-Bic 



T''fnaH®i?I^?!!°!^"- 3' = ^'le-newer-thon-instaHed-p ("Sin-tFASL") NIL 
NIL) 
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(ti :d«f tne-8imple-tran»format ion ; atm-micro-comp) le 

■licrotsim-compi le-f i /ft-1 si : f i le-neuer-than-f E t*-p C^LrSP") {"SIH-QPASL") 
(**Cotnpiie simulatea micrcccde" "CoJnpi(ing eimuiatcd microcode" 
•compiled simulated mlcpocoae") 
t) 
(def macro (: si»-»)cro-cofflpi le-!oad si :def«ytte«-«iacro) (input ^optional com-dcp load-dep 
,, . . I ^ / . . . co»-cond toad-cond) 

l:si»-«icro-load 1:8 tm-micro-compi te .input ,coii-dep ,co«-cond} 
,lo3d-dEp , load-condJ) 
Cdefaacro (: siw-micro-compi te-load-ini t 8i idefsysten-Bacro) (input add-dep 

^optional con-dep (oad-dep 
, ^ ^ ^. 4aux function) 

(»etq funct ton 

( let-closed ((si:»3ddi t ional-dependent-Bodutes« 
, . (siiparce-tnodule-components add-dep ei:«8yste»-being-def tned«) )) 
8 1 ; cowp r I e- 1 oad- 1 n j t-cond i t i on) ) 
M:8i»-tticro-load (rsio-nicro-coapi le .input ,coa-dep .function) .load-dep)) 
(defsystea Microcode 

(rpathnawe-default "SYS: L-XOOE;") 

(:patchadle) jFop the sake of niCROCOOE-VERSION 

( : no t- i n-d i sk - 1 aba i ) 

<:cottponent-sy8teM8 tac-aicrocode) ) :Load just this version nou 

(coaaent ;th)8 doesn't uork any aore. soae of tha aacros have been diked out 
(defsystea proto-aicrocode 

(:pathnaae-default "SYS: L-UCt30E;M 

(laodule call-defs ("FUNCALL" ;t1acro definitions for function calling 

"FUNCALL2" -CATCH-)) ;def3reg*9 used In FUNCALL3 
(:aodule call ("FUfCALLl" -.Expand the function-call aacros 

"FUNCALL3")) jRandom function-call routines 

(:aodule ari thmet ic-def s ■ARITH-ESCAPE") ;Oefinitions needed to compile arithaetic 
(laodule arithmetic "ARITH") 

(raodule aul tiplu-divide CnULTIPLY" ■DIVISION")) 
(:aodule array (^ARRAY**)) 
(saodule control ("CONTROL")) 

(xaoduie other-aicrocode ("BASIC" "BRANCH" "PREDICATE" "SUBPRIM" "SYTl" "BIND" 

"STACK-BUFFER" "SG" "FLAVOR- MFU" 
■ATEn-riAP" "PROTQ-TRAP" "BITBLT")) 
(:aodute floating-point ("FLOAT")) 
(taodule aicrocode (call-defs call urrM\j other-aicrocode floating-point)) 



( : pr to-a i cro-comp 
( : pro to-a i cro-coap 

( : pro to-a i cro-cowp 
(: pro to-a i cro-coap 
(:proto-aicro-cofflp 
(: pro to-a t cro-comp 
(:proto-ai cro-comp 
(:proto-ai cro-comp 
(:proto-ai cro-coap 



! I e- 1 oad cat t-defs) 

f Je-load-init call call-defs (:proto-aicro-load call-defs) 

(:proto-aicro-load call-defs)) 
iJe-foad ari thaet tc-dcfs) 

la-ioad auitiply-divido (:proto-aicro-foad ari thaet ic-def s)) 
I e- I oad arithaetic (tproto-aicro-load ari thmet ic-def s aul tip ly-di vide)) 
te-load array (:proto-aicro-load ar i thaet ic-def s aul tip ly-di vide) ) 
1 8- 1 oad control) 

le-load other-aicrocode (jproto-aicro-load control)) 
>ile-load floating-point 

(:proto-aicro-load arf thaet ic-def s aultiply-divide))) 
); coaaent 

(defsystem tac-aicrocode 

(ipathnane-default "SYS: L-UCOQE;") 

(raodule call-defs ("FU^iCALL" :nacro definitions for function calling 

, . , .. .-r-..^!f^t:**:^^*-2" "CATCH")) ;defarcg's used in FUTJCALLS ^ 

(:aoduIe call ("FUNCALLl" ;Expand the function-call aacros 

"FUf4CALL3")) _ ^ ;Random function-call routines 

(:aodule ar i thmet ic-def s^"ARITH-ESCAPE") jDefinitions needed to coapile arithaetic 
(saodule arithmetic "ARITH") 

(:»odule aul t iplu-di vide ("MULTIPLY" "DIVISION")) 
(: module array (*ARRAYM) 
(:aodute control ("CONTROL")) 

(:aodule other-aicrocode ("BASIC" "BRANCH" "PREDICATE" "SUBPRin" "SYfl" "BIND" 
. .„,^^., "STACK-BUFFER- "SG" "FLAVOR" "nAP" "TRAP" "BITBLT"}) 
(:aodule disk "DISK") 
(saodule net "NET") 
(saodule floating-point ("FLOAT")) 
(saodule aicrocode (call-defs call array other-aicrocode floating-point)) 

(: tmc-aicro-compi le-)oad cal l-defs) 

(stac-aicro-compi le-load- i nit call call-defs (s tac-aicro-load call-defs) 

, ^ . (s tac-aicro-load cal I-defs)) 

( s tac-B I cro-comp 1 1 e- 1 oad ar i thaet i c-def s) 

(stac-micro-compi le-load aul tipfy-divide (: tac-aicro-load ar i thaet i c-def s)) 

(stac-aicro-compi le-load arithaetic (s tac-aicro-load ari thmet ic-def a aultiply-divide)) 

(:tac-Bicro-compi le-load array (s tac-aicro-load ari thaet ic-def s aut tiply-divide)) 

(: tmc-m I cro-comp i le-load control) 

(stmc-micro-compi le-load other-aicrocode (s tac-aicro-toad control)) 

(: tmc-aicro-compi le-load disk) 

(s tmc-aicro-compi le-load net (s tmc-micro-load disk)) 

(stac-aicro-coapi le-load floating-point (s tac-aicro-load ari thaet ic-def s aultiply-divide))) 

(defsystem tmcS-alcrocode 

(spathname-defauit "SYS: L-UCOOE;") 

(saodule call-defs ^.^FqifALL"^ .^.Tr^^.., ^"aci^o definitions for function calling 

^.. H i .. ,-r.«.>rIfP^;*9^^2 "CATCH")) ;defareg's used in FUNCALL3 ^ 

(saodule call (^PUJCALLl" jExpand the function-call aacrot 

FUNCALL3")) sRandoa function-call routines 
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(:Bodule ar i thmet ic-def s "ARITH-ESCAPE") {Definitions needed to coapile arithaettc 

(imodule arithmetic ^'ARITH") 

(:module mul t iply-di vide ("HULTIPLY" "DIVISIONS) 

(:mcclute array ('^ARRAY")) 

(tncdule control (•'CONTROL") ) 

(:modute other-microcode ("BASIC "BRA^^:H" "PREDICATE" "SUBPRIM" "SYTI" "BIMD^ 

, ^ , . .^. -STACiC-BUFFER" "SG" -FLAVOR" TIAP" "TRAP" "BITBLT")) 

(;moduie disk "DISK") 

{:moduie net "NET") 

(:module floating-point ("FLOAT")) 

liBodule Bicrocode (cal l-defa call array other-nicpocode floating-point)) 

htmcS-micro-compi ie-!oad call-defs) 

i:tmcb-tt.cro-compi(e-ioad-init call cal t-defi (: tmcS-nicro-load cal l-defa) 

(.♦r-t; mirro ^«* • . i ( z tdicS-B i cpo- 1 oad call-defs)) 

:;«:|"!'r°"'^°'"P! ®"'°3d arithmetic-defe) 
^ utie.::-wicro- coffipMe-load mul t iply-di vide (: tmc5-mi cro- toad ari thmetic-def a) ) 

(: tBcS-aicpo-compi le-load arithmetic (: tucS-ai cro- load ar I th«etic-def8 rul t iplu-divide) ) 
(: t«c5-»icro-compi le-load array (: tmc5-»i cro- load ar t thmet ic-daf • «ul t iply-di vide) ) 

(: t»c5-»icro-cor.pi le-(o3d control) 

(:t»c5-»icro-cofflpi te-load other-«fcrocoda (: t«c5-«i cro- load control)) 

(: tBc5-»icro-comp( le-io3d disk) 

(: t«c5-«icro-compi le-Ioad net istatcS-micro-Foad disk)) 

(: t»c5-»tcro-compj le-load f foattng-point 

I: tmcS-aicro-load ari thmet ic-defs rul t ipiy-divide) )) 

(defsyatea i fu-aicrocode 

(rpathname-default "SYS: L-UCODE;") 

(:Bobule call-defa ("FUNCALL" tflacro definitions for function calling 

. «.. ., r-c./JH^^^^^" ■C^™">> ;defareg's used in FUfCALLS 
(iKoAile call ("FUNCALLl" :Expand the funct ion-cal i macros 

"FUr^CALLS")) {Random function-call routines 

(;»odule ar t thmet ic-defs"ARITH-ESCAPE") {Definitions needed to compile arithmetic 
<:«odule arithmetic "ARITH") 

(:»odule multiply-divide ("nULTIPLY" ^DIVISION")) 
(tmodule array (^ARRAY")) 
(tmoduie control ("CONTROL")) 

(zmodule other-Bicrocf:de ("BASIC" "BRANCH" "PREDICATE" "SUBPRIH" "SYM" "BIND" 
, ^ . -r,,^^., "STACK-BUFFER" "SG" "FLAVOR" "nAP" "TRAP" "BITBLT")) 
(:»odule disk "DISJC") 
(rmoduie net "NET") 
{:modulc floating-point ("FLOAT")) 
(:JK>dute microcode (call-defa call array other-microcode floating-point)) 

(: i f li-m i cro-comp i I e- 1 oad ca 1 1 -def a) 

(:ifu-micro-compi le-load-ini t call call-defa (x Ifu-mtcro-load call-defa) 

, ., . ., . (j ifu-micro-load cal l-defs)) 

(: tfu-m I cro-comp 1 (e-foad an thmet ic-defs) 

(:ifu-micro-compi le-ioad mul tiplu-divide (: tfu-micro-Ioad ari thmet ic-defs) ) 

(: ifu-micro-compi le-load arithmetic (; i fu-»icro-lcad ari thmet ic-defa muJ t iply-divide) ) 

(tifu-micro-compi le-?aad array (i ifu-micro-load ari thmet ic-defa mul tipiu-divide)) 

(: I fu-m I cro-comp i ^e- load control) 

(: jfu-mi cro-comp i le-load other-microcode (: i fu-micro-load control)) 

I: ifu-mtcro-compi le-Ioad disk) 

(: ifu-mi cro-comp i te- I oad net (: i fu-micro-load disk)) 

(: I fu-m I cro-comp i le-load floating-point (: ifu-micro-load ari thmetic-defs multiply-divide)) ) 

(defsyatem aim-microcode 

{:pathname-default "SYS: L-UCODE;") 

{:moduie call-defa (."PUNCALL" ,^,^^.,, :«acro definitiona for function calling 

i ^ . ^ .. /.c,,.,rirH'^?'^'-'-^ "CATCH")) {defareg's used in FUTOLLS 

(:module call ^.P^UNCALLl" ^ {Expand the function-call macroa 

, ^ , FUNCALL3"J> {Random function-call routinea 

:modu e ar . thmet ic-defs-ARITH-ESCAF£") {Definitiona needed to compile arithmetic 
(:modute arithmetic ARiTH") 

(tmodule multiply-divide ("tlULTIPLY" "DIVISION")) 
(:«odule array (*ARRAY")) 
(:moclule other-microcode ("BASIC" "BRANCH" "PREDICATE" "SUBPRIM" "SYH" "BirjD" 

•STACIC-BUFFER" "SG" "FLAVOR" "IFU" "BITBLT")) 
(zmodule floating-point ("FLOAT")) 
(imodule ari thmet ic-instructiona "ARITH") 

(tmodule microcode (call-defs call array other-microcode floating-point)) 
;I am apparently not permitted by the taatefulneaa committee to name mu files .SIM 
;(:module teat-caaea ("FACT. Sin" "FAKE-ARRAY")) u <j « -y tmcs .oiu 

(: aim-mi cro-comp i le-load cal l-defa) 

(:sim-mtcro-compi le-load-ini t call call-defa (: aim-mi cro- I oad call-defs) 

/... ., , , (:ti»-micro-ioad cal l-defs)) 

} : a I m-m i cro-comp i I e- 1 oad ar i thmet i c-def a) 

(:aim-micro-compi le-load multiply-divide (s aim-micro-load ari thmet ic-defa) ) 

l:8|m-micpo-compi le-load arithmetic (: aim-mi cro- load ari thmet ic-defa multiply-divide)) 

j: a im-mi cro-comp I le-load array (taim-micro-load ari thmet ic-defa mul tiplu-divide)) 

(:Bie-micro-compi le-load other-microcode) 

. /?II!lIlll^7°"?°'"?' '®"'°^*^/l°®*'"3"P°'"* (:8im-micro-load ari thmet ic-defa multiply-divide)) 
{(:readfile teat-caaea {(tfaaload microcode) ^ 

j (rfaatoad call-defa call other-microcode)) 
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F:>1mach>ucode>ZVEI.LISP.2 

;;; -«- HodeiLISP; Packagft:Zl£I ; Base:S: Louercate: T -»- 

(login-aval (tat-coatab-r a turn-undo astandard-coatab* 

* (;t^\Hyper-Supar-X coa-Klcro-axpand-aexp) )) 

(defcoa coa-aicro-axpand-sexp 

"Hicroexpand S^axprassion. Uith ragton, aicroexpand rag ion" C) 
(lat ((streaa {rest-of-interval-straaw (point)))) 
(lat Ufora (read atreaa '»eof:t:})) 
(and (eq fora *»«of«) (barf)) 

(»icro:bettep-8pr inter (a icro: aicroexpand fora)))) 
dia-none) 

F :>1mach>ucode>uux . 1 1$p . 6 

;;; -a- flodetLisp; Packaqe: Micro; Base: 8; Louarcaaetuas -a- 
St; (c) Copyright 13&2, Symbol lea, Inc. 

; This fits contains stuff that uould ba in UU except that it cannot ba 
; loaded until after the ays tea definition file haa been read in 

(dafconat aundupl icated-data-typesa 

(remq 'dtp-fix (reaq ^dtp-float adata-typesa 15.) IS*)) 

;The type aap for noraal arithaetic^ uhich has cond for non-ftxnua numbers 
;and bad-argument trap for non-numbers. 
(defconst »ar i th»etic-type-03p« 
M((dtp-fix)) 

((dtp-float dtp-extended-nurober) cond) 

(, (types-other-than '(dtp-fix dtp-fioat dtp-extended-nuaber) ) trap-8))) 

;Ar1th»etic trap dispatches on ABUS<33:32>|BBUS<33:32> 
;3 in either field can't happen, if a type check was done 
;Unfortunateiy this isn't really true, since Bbus type checking incomplete 
(defconst «ar i thmetic-trap-dispatch-cues-al ista 
• ( (extnum-extnum , 8) 

(extnum-f ixnun • 1) 

(extnu»-f Icnua . 2) 

(f ixnuw-extnua . 4) 

(f ixnuR-f ixnua * 5) 

(f ixnum-f lonua . B) 

(f lonufi-extnua . 18) 

(f lonum-f ixnuM , 11) 

(f lonuR-f ionua . 12))) 

;Storing into memory 

;The type aap for normal storing, which si*ply identifies whether or 

:not a pointer is being stored. This is what enables the gc tag hardware, 

(defconst *s t or ing- type-map* 

•(((dtp-null dtp-nil dtp-symbol dtp-extended-nunber 

dtp-ex terna I -va 1 u2-ce I T-po i nter dtp- 1 oca t i ve 

dtp-list dtp-compi ted-funct ion dtp-array dtp-closure 

dtp-instance dtp-hcader-p dtp-even-pc 

dtp-one-q-foruard dtp-header-foruard dtp-odd-pc dtp-aoni tor-forward) 
pointer))) 

jEleaent 8 is always the no- trap type aap 
(if (null »type-n;ap5«) 

(assign- type-nap nil)) 

F:>liitch>ucode>uu. lisp. 429 

;;; -»- tlodaiLiap; Pack age: nicro; Base:8; Louercaaetyes -«- 
;:; (c) Copyright 1SS2, byaboCics, Inc. 

;Pr iaitive forms of aicrocodet 

t (aicroinstruction field value f le^d value*.,! 

; (aicroscquence instruction instruction...) 

; aicrosequence always contains at least two instructions 

t (aicrodata place code) 

; place is where in the machine the data is (typically a bus) 

• code is microcode to put it there ( instruct ion or sequence) 

; (aicrocondi t ion condition sense code) 

J condition is the name of a skip condition in the machine 

; and code is microcode to put a boolean condition into it 

; sense is one of the symbois true, false 

;For non-primitive forms of microcode, see the dofmicros below. 

;Particular ly important are: 

$ (sequential code code code.,.) 

; Generates a aicrosequence. Note that the last piece of code 

; may be a aicrcdata/fflicrocondi tion and the right thing will happen. 

% (parallel code code code...) 

; Does an the operations in parallel, barfing if that la impossible. 

; Uhen sequences 9re done "in parallel", the result is a sequence; 

{ the first state of a sequence is done in parallel with what comes 

X before it in the 'para Mel' form, and the last state ie done in 

; parallel with uhat coues after it. 
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;To do: More pr't»itiv« operstrons 

; ALU operations need to have word length (2S or 32) 

J (actually I don't think they doJ 

: ASSIGN to a byte trashes the cdr code of the uord assigned to. 

J Ouqht to preserve it unless it is tibus or set-cdr-code is done. 

; Can IF inside of a aicrodata be cade to work (turn inside out)?? 

; Can (PARALLEL (IF .,.) FCO) nove the FOO into each ara of cond? 

; Can ASSIGN be table-driven? 

; Semi -open subroutines, where the first instruction is open coded 

; and it calls off to the re«t 

;;; Variables associated with storing the results 

(defvar *ucode-aI ist*al t 8t« nil) 

;Each clement is (nachine-version , alist) 

;Each element of that atist is (tag aicrocode assenbled-Bicrocode) 

(defvar «top-level-code«) ;For when the compiler fondles ursines 

; see ^machine-version* 

(defvar «need-to-l ink* ni I) ;Set to T when n ew ■icrocodo defined,- to NIL by linker 

;;: Debugging Toots 

(defvar *»icrocxpand-trace« ni I) ;Set this to T for debugging 

(defvar stjacktrace* nil) 

(defconst non-backtraced-foras '{paranel »equenttal)} 

(defprop ■icroinstruct ion (1 2 2) ba^format) 

(defprop Bicrosequence (1 1 2) bs-format) 

(defprop Bicrodata (2 2 2) bs-format) 

(defprop ■icrocondi t ion (3 2 2) bs-format) 

*n (defprop better-sprinter {(dsk Imucode) better-sprinter fasll autoload) 

(declare (»expr better-sprinter)) :Ueli, maybe 3 little better 

(defvar ppf) stast input 
(defvar ppx) jLast output 

(defun ppx (Optional (form ppf) («™icroexpand-trace« »niicroexpand-trace*)) 
(better-sprinter (setq ppx (wicroexpand (setq ppf form))))) 

(declare (special defucode-ai ist) ) ;defvar'ed later in the file 
(defun ppu (defucode) 

(better-sprinter (cadr (assq defucode (cdr (assq vmachine-version* njcode-al i st-al i sts) ) ) ) ) ) 

m 

(defun retch (format-string &rest args) 

(declare (special args)) ;For accesstbi I i tu fro» breakpoint 

(let ((^ nil) O nTl) (^qnil)) 
(format msgfiles '*'»^>>Error: ") 

(lexpr-funcal I tt' format msgfiles format-string args) 
(foraat msgfiles "'^4 Oicroexpand backtrace: .^i-c^X *2: ;*A'*>*»^, ^^J-^X' 

«back trace*) 
(break retch t))) 

mi 

(def flavor mi croexpans ion-error (format-string format-args backtrace) 

(sys: no-act ion-«ixin error) 
: ini table-instance-var tables) 

(def method (microexpans ion-error : report) (stream) 

( lexpr-funcal I Jif* format stream format-string format-args) 

(format stream "--i Hicroexpand backtrace: •{*<*! ^S: ;~A'->*^, -vJ-X" backtrace)) 

(compi le-f lavor-methods microexpansion-error) 

)SfQ 

(defprop retch t terror-reporter) 

tfQ 

(defun retch (format-string firest args) 

(signal 'microexpans ion-error ': format-string format-string 

*: format-args vcopylist args) 
*:backtrace *backtrace*) 
ni t) 

(eval-when (compile load evat) 
(defun fintern (string firest args) 

(intern ( 1 expr-f uncal J )Sf* format nil string args)))) 
;;; Implementation of micros 

(defun microexpand (form) 

(let ((«back trace* sbacktrace*) ) 

(loop as new- form • (aicroexpand-l form) 
when (eq new-form form) return form 
do (setq form new-form)))) 

(defun microexpand-1 (form &aux tern) 
(cond ((atom form) 
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(cond {(and (symbolp form) (setq tea (get forta 'atoaic-BiicPo) } ) 
(push for» «t33cktrace»} 
tem) 

(t form)}) 
((seta tem (get (car for*} *iRicro)) 
(op (»eBq (car form) non-backtraced-for«9) 

(push (car fora) ^backtrace*) ) 
(setq tea (funcall tea fora)) 
(cond (itmicroexpand-trace* 

(format t "-wA Hicroexpand of:") 
(better-sprinter form) 
(format t "^ into:") 
(better-sprinter tea))) 
tem) 
(t form})) 

(defun aicrocxpand-to-paraMel (fora) 
(let ((«back trace* »backtrace«) ) 

(loop as neu-forn - (aicroexpand-1 fora) 
when (eq new-form form) return fora 
do (setq fora new-fora) 

uhen (and (not (atom fora)) (eq (car fora) *paraMel)) 
return fora) ) ) 



(defaacro def micro (name args 4body body) 
Meval-when (compile ioadcva!) 



tfQ (si:rccord-source-f i le-name \nane •defmlcro) 
(defun (,na»e micro) (+form+) 
, (defmicro-nargs-check arga) jCheck number of arguments 

(let» , (defmtcro-args argsl ;Bind argument variables 

« ,bodu)))) 

(eval-when (compile loadeval) 

(defun defmicro-nargs-check (pattern) ;Return code to check nargs 

(loop for p in pattern with optional ■ nil uith required • t 
when (eq p '4opt tonal) .. 

do (setq required nil optional t) 
else uhen (memq p ' (&rest &body) ) 

return * (and (< (length +form+) ,(1+ nreq) ) 

(dcfaicro-wrong-number-of-args 4-forB-*-)) 
else uhen (eq p *&aux) 

do (setq required nil optional nil) 
else count optional into nopt 
and count required into nreq 
finally (return '(or (lessp ♦nreq (length +fora+} , (+ nreq nopt 2)) 
(def a i cro-urong-number-of-args +f ora+) ) ) ) ) 

(defun defmicro-args (pattern) jReturn arg binding let clauses 

(loop for p m pattern with kind • 'Arequired with idx « 
when (eq p •ioptionaf) 

do (setq kind *&optional) 
else when (eq p *&3ux) 
do (setq kind *&aux) 
else uhen (memq p ' (&rest &body) ) 

do (setq kind *Arest) 
else do (tncf idx) 
and uhen (atom p) 

collect M.p ,(setectq kind 

((^required ^optional) '(nth , (cfx +fora+)) 
((&rcst) *(nthcdr .idx +for»+n 
(otherwf ee n\ \))) 
else col lect *(, (car p) 

, (fie/ectq kind 

((^required) '(nth ,idx +form+)) 
((doptionat) '(if (nthcdr Jdx+fora+) 
(nth , idx +for«+) 
, (cadr p))) 
((irest) '(nthcdr ,idx +forn+}) 
(otheruise (cadr p)))))) 

(defun defmi cro-urong-number-of-args (x) 

u i^^i. defaicro uas called with too many or too few arguaentst-rt •S" x)) 

' t evo 1 — unen 

;Expansion is microcode, not Lisp: no backquotes, please. 
(deUiacro defatomtcro (name expansion) 
(eval-uhen Ccompi ie load evat) 

«''-record-source-fiie-name \name *defato»tcro) 
(defprop .name .expansion atomic-micro))) 

;For internal use from other forms: don't record a source file name 
(•val-when (compile load eval) 
(defun add-atoaicro (naae expansion) 
. (putprop name expansion 'atoaic-aicro) ) 
): eval-uhen (coapi Ie load eval) 

;j; Priaitive micros 

(declare («lexpr paralyze)) 

(defmi cro sequential (ibody forms) 

(aicrosequoncize laapcar t^'microcxpand forms))) 
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(defun microsequencire (Mat) 
(cond ({nui I I ist) ni I) 

((nul [ (cdr list)) (car 1 ist)) 

(l»e«iq (caar (last list)) * (microdata ■icrocondi t ion) ) 
(let ((data (car (last Mst))) 

(♦backtrace* (cons * (microscquencize-»ns ide-out) *bscKtrace«) ) ) 
(let ( (code (aicrosequencize (nconc (nbut last list) 

,. , , , . (neons (car (last data))))))) 

(if (eq (car data) microdata) 

(make-microdata (cadr data) cods) 

(niske-microcondi tion (cadr data) (caddr data) code))))) 
(t (cons 'microsequence 

( loop for form in list 
when (atos form) 
do (or (nuM form) 

Wretch "^S where ■icpo instruct ion expected" 
form)) 
else when (eq (car for»} *«icpoinstruct ion) 

col lect form 
else when (eq (car for«) '«tcro9equence) 

append (cdr form) 
else do (retch "^S uhere nicro instruct I on expected" 
form)))))) 



(defwicro pa^^aliel (fibody forms) 
:Start bg expanding and flattening, then mcroB together instructions 
;that are supposed to be done in parallel. If we see a sequence, pick 
;out tts first and last instructions and aerge thea with the things 
;before and the things after. 
(■icrosequenci ze 

(loop with current - (neons 'microinstruction) 
for form in (f I at ten-paral le I s forms) 
when (atom form) 

do (and form (retch "-S gareaae in parallel construction" form)) 
else when (eq icar forml *citcrosequence) 
when (cddr form) 

collect (merge-instruct ions current (cadr form)) into res 
and do (setq current (copijMst (car (last form)))) 
and when (cOddr form) 

collect (microaequencize (butlast (cddr form))) into res 
else do ni t : no middle 

else do (setq current (merge-instruct ions current (cadr form))) 
else do (setq current (merge-instruct ions current form)) 
finally (return (nconc res (neons current)))))) 

(defun f latten-paral lels (forms) 
(loop for form in forms 

do (setq form (tnicroexpand-to-paral lei form)) 

when (and (not (atom form)) (eq (car form) •parallel)) 

nconc (f latten-paral lela (cdr form)) 
cl se col lect form) ) 

;Smash one instruction with another, and return the result. 
;Note that p|ist-l is actually modified, because that's what parallel wants. 
;Note that either pi ist can be microdata/microcondi t ion rather than a 
-.microinstruction pi ist. In that case, we want to return a microdata 
;as our result. Both plists being data is illegal, we don't do 
;nondeterminist ic joins. (You should store one aomeplace first.) 
;i don t know how to merge data and conditions; that could actuallu be useful. 
♦°y iu ^^^' "® preserve the order of operations in the plists even 
'^2 * ^°^* 9^ Bcmewhat slower computation, just to make debugging nicer, 
(defun nerge-mstructions (piist-l plist-2) 
(cond ((eq (car plist-l) ^microdata) 

(cond ((eq (car pliEt-2) *mterodata) 



(retch Tryinq two merno two pieces of data: •'S and *S" 
p! ist-I ■ ■ ■ " 

p!ist-n 



ist-i pi i8t-2> 



((eq (car pltst-2) 'microinstruction) 
(merge-instruction-and-data plist-2 plist-D) 
//-« t i^ 1?^?^/"'? invalid - merge-instruct ions" prt8t-2)))) 
^^=5 (car pt ist-1) 'microcondition) 
icond ((cq (car pIi3t-2) 'microinstruction) 

(merge-instruct ion-and-condition pIist-2 plist-D) 
iirnn (rL r.V^^. ^r^, invalid - merge- i nstruct i ons" pli8t-2)))) 
I req (car phat-1) 'microinstruction) 

( Pn^^=>."^.'"!^4l'^." merge-instruetions" plist-D) 
neq (car plist-2) 'microdata) 

( calc^r^niic^U?'':'*"^-^^^^ Pliet;-! plist-2)) 

Mcq icar plist-2) 'mcroeondi tion) 

i-.e ge-mstruction-and-ecndi tion plist-l plist-2)) 
M?*^.^??^ P' ••^-2) 'microinstruction) 

(let ( Kbl get pM»t-l 'xbus)) (gbl (get plist-l 'ubus)) 

(and xb2 (eq xb2 gbl))) 
(multiole-value (pIist-1 Dli8t-2) 
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(merge-dus-tcheciul ing plitt-1 pIi8t-2)))) 
(nconc pi iBt-i 

(loop for (prep vat2) on (cdp pMst-Z) fay *cddr with fen 
as vail • (get plitt-l prop) 
uhen (not vatl) 

collect prop and collect val2 ;i«e. putprop 
else when (equal vail va I 2) 

do ni I 
else uhen (setq fen (get prop 'iierge-f lelds) ) 

do (putprop plist-l (funcall fen vail val2) prop) 
;Thi8 kludge it because ar i thast ic-trap-enb has 
:two spec codes, one with dispatch and one without, 
;Takes care of other hair with »agtc bit8» too. 
else when (and (memq prop Mspec «agic)) 

(merge-spec-magic plist-l pIlst-2)) 
do nil tslreadu hacked bu Merge-spec-ndgic 
• Ite do (retch "Field conflict: *S has *S and -vS" 

i. i . w - e . .. P'^oP ^**1 vai2)))) 

Ct (retch "-^S invalid - ■•rge- Instruct ions" pIist-2)))) 

: Re turn the sane data, but do the instruction in parallel with it 
(defun ■erge-instructicn-and-data (instruction data) 

(let ((mbacktrace* (cons ' (ncrge-instruction-and-data) «backtrace«))) 
(make-eicrodata (cadr data) (paralyze (caddr data) instruction)))) 

jReturn the sane condition, but do the instruction in parallel with it 
(defun aerge-instruction-and-condition (instruction condition) 

(let ((^backtrace* (cons ' (»erge-(nstruction-and-condi tion) «backtrace»))) 
(«ake-»(crocondi tion (cadr condition) 
(caddr condi tion) 
(paralyze (cadddr condition) instruction)))) 

;This is sort of the subr version of parallel, or the nap version of nerge-instructions. 
(defun paralyze (4rest instructions) 
;lf we see a sequence, pick out its first and last instructions 
;and eergc then with the things before and the things after, 
(■icroseouencize 

(loop with current • (neons •■tcroinstruction) 
for instr in instructions 
when (ato» instr) 

do (and instr (retch "^B garbage in paralyze" instr)) 
else when (eq (car instr) 'aicrosequence) 
when (cddr instr) 

collect (r.erge-instructions current (cadr instr)) into res 
and do (setq current (copytist (car (last instr)))) 
and when (cdddr instr) 

collect (nicrosequencize (butlast (cddr instr))) into res 
else do ni I ;no niddle 

else do (setq current (merge-instructions current (cadr instr))) 
else do (setq current (merge-instructions current instr)) 
finally (return (nconc res (neons current)))))) 



(defun iierge-spec-magic iplist-l pnst-2 

^ ^j ftaux sped spec2 eagicl ■agic2 new-spec new-nagic) 

(setq specl (aet pMst-l *spec) 8pec2 (get plist-2 'spec) 
Btagicl Iget plist-l •magic) «agic2 (get ■• - ■ 



;; If the . 
(cond ((and 



nagicl (get plist-l •magic) «agic2 (get pli8t-2 '«agic)) 
t! \^^ *P*^ fields differ, try to find a common value 

spec fields are the same, still some magic-number merging to do 
Id (meiTiq specl (ar i thmet ic-trap-enb ar i thmet ic-trap-wi th-dispatch) ) 
(meiriq specZ (ari thmet ic-trap-enb ari thmet ic-trap-wi th-di spatch) ) ) 
1 1 f (nul I maaicl) 

/•^ 1'"®!':^ "nissing magic number field in -vS" plist-D) 
(if (nul I maQic2) 

(retch "Hissing magic number field in -^S" pliet-2)) 
isetq new-spec (if (and (eq specl 'ari thmet ic-trap-enb) 

(eq Bpec2 *ari thmet ic-trap-enb) ) 
ar I thmet ic-trap-enb 
•ar i thmet ic-trap-wi th-di spatch) 
It M "^"-'"aQic (logior magi el magic2))) 

i^t^^ ^^^^k , (arith:!ietic-trap-enb ari thmet ic-trap-wi th-dispatch) ) 
imemq 6pec2 (trap-i f-type-cond 

/...„ ^ trap-t f-type-cond-or-bbus-not-f ixnum))} 

tsetq new-spec specl 

neu-magic (logior (or magicl 0) 
((anH /*p-.n .^.^o w ...*'^*^^ Bpec2 'trap-i f-type-cond) 1 3)))) 
Man. tfferrq spec2 (ar i thmet ic-trap-enb ar i thmet ic-trap-wi th-di spatch) ) 
(aeaq specl ' (trap-i f-type-cond 

... trap-i f-type-cond-or-bbus-not-fixnum))) 

(setq new-spec 8pec2 

new-magic (logior (or ■8gic2 0) 

(if (eq specl ' trap-i f-type-cond) 1 3)))) 
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((and (meraq sped * (trap- i f-type-cond 

trap-i f-typff-cond-or-bbu9-not-f i xnum) ) 
(nenq 9pec2 * (trap-t f-type-cond 

tpap-if-type-cond-or-bbus-not-f ixnum))) 
(putprop plist-1 • tpap-if-type-cond-or-bbu9-not-f ixnuB *«pec) 
(return t) ) 
((and tor (and teq snecl *ar i thrret ic-trap-enbl f-« manicl 3)) 
(eq sped trap- ) f-type-cond-or-bbus-not-f i xnum) ) 
(»emq specZ * (multiply mul t iply-and-type-check) ) ) 
(setq new-spec * (nu I tip ly-and- type-check 
new-magic magtcz)) 
((and (or (and (eq specZ 'ar t thwetic-trap-enb) (- aagicZ 3)) 
(eq epec2 trap-i f-type-cond-or-bbus-not-f ixnura)) 
(memq sped * (multiply tnul t iply-and-type-check) ) ) 
(setq new-spec 'mul tiply-and- type-check 
new-aagic maqicln 
((and (memq sped Mmuftiply mui t iply-and-type-check) ) 
'(mcmq spec2 '(multiply mui t tply-and-tupe-check) }) 
;; Can ior the fields together except for Xbus read/write conflict 
(if (or (and (bit-test 2 tiagid) sHagicl writes from xbus 

(not (bit-test 2 ragicZ)) ;nagic2 reads onto xbus 
(bit-test 4 «iagic2)r 
(and (bit-test 2 Kagic2) 

(not (bit-test 2 magicl)} 
(bit-test 4 Ragicl))) 
(retch "riultiptier both reading and writing xbus, nagtc -^ ^' 
mag id r.agic2)) 
(setq new-spec (if (and (eq sped 'iiultiply) (eq «pec2 •«uitiplu)) 
•■uitiply 

* mu 1 1 i p I y-and- tupe-check) 
new-magic flog ior magicl BagicZ))) 
((and magicl magic2 (not (and sped epec2 (not (eq sped spec2)})) 
(zercp (togand (setq sped (or (gat plist-l •magic-mask) 17)) 

(logxor raqicl (log ior nag id magic2)))) 
(zerop (logand (eetq specZ (or (get plist-2 'magic-mask) 17)) 
(logxor (log tor magicl magic2) Bagic2)))) 
;: Conflict in Rogic number field only, and the bits that differ 
:; are on!g bits that the magic-mask claims are not cared about, 
(putprop pTist-1 (logior magicl magic2) •«agic) 
(if (- (logior sped 8pec2) 17) 
(remprop plist-l 'magic-mask) 

(putprop plist-l (logior sped «pec2) 'magic-mask)) 
(return t)) 
(t (return nil)) J ;Cannot resolve spec conflict 

s; Now make any alterations caUed for 
(putprop plist-l new-spec 'spec) 
(putprop plist-l new-magic 'magic) 
(renprop plist-l *mag i c-cask) 
(return t) ) ) 

;n)£gic-maEk better occur after magic in the microinstructions 
(defprcp magic-mask logior merge-f ields) 

jTaKe care of some simple cases of lossage caused by Xbus select and Ybus select 
;being the same bit. plist-l is the one that can be modified. 
(defun merge-bus-schedut ing (ptist-l pli8t-2) 

(ccnd ((and (eq (get plist-2 'ybus) (get plist-l 'xbus)) 
(fieldp plist-2 'condition 'ybus-SD 
(not (Get pli8t-2 'byte-funcf) 
(not (?ieidp plist-2 'spec 'multiply)) 
(memq (get plist-2 'alu) '(nit xbus)) 
(memq (get plist-l 'alu) '(nil xbus))) 
;; ptist-2 isn't doing anything with Ybus except testing the sign, 
;; and the ALU is available, so do the sign test there. 
(setq plist-2 (copylist plist-Z)) 
(rerprop pi ist-2 ^yDus) 
(putprop pli8t-2 'xbus 'alu) 
(putprop plist-2 •stu-31 'condition)) 
((and (eq (get pMst-1 'ybus) foet pii8t-2 'xbus)) 
(fietdp piist-1 'condition 'ubue-SD 
(not (get plist-l 'byte-funcD 
(not (fieido pMst-1 'spec 'muttipty)) 
(memq (get plist-l 'alu) '(nil xbusf) 
(memq (get plist-2 'alu) '(nil xbus))) 
;: plist-1 isn't doing anything with Ybus except testing the sign, 
:; and the ALU is available, so do the sign test there. 
(remprop pi ist-l 'yfcus) 
putprop plist-1 'xbus 'alu) 

{w;;tt,». £V^^^°? p!'^*-^ 'alu-Sl 'condition))) 
ivatuec pi ist-1 p) t8t-2)) 

^''i;^:^?^"^^ "fgf-f'elds) (cpeedl speed2) 

^■'■' Ue^ 1111^2 ^Vll":] llllill '»'°" ^"^ "« d°"*^ c^-« »^'^^^ half 

(t'''ve-'^-s?^';?l/''^'"y-®'0"* <«q speed2 'very-slow)) 'very-slow) 

" ^'-^^^V -must be both hafves slow 

•/i'/"'^'"° and macro for machine-version condi t ional izat ion 
(defmacro machine-vers ion-case (ibody clauses) 
lexpand-mach i ne-ver » i on-case c I auses) ) 
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(defaicro wachine-version-case (ibody clauses) 
(•xpand-nach i ne-vers t on-case c I auses) ) 

(defun expand-oachine-versicn-case (ci auses) 
(loop for clause in cf auses do 
(or <- ( length clause) 2) 

(ferror nil "^S it legal clause in ^ACHI^£-YERS10N-CASE; irust be f<vcr> <code>)* 
clause)} 
(if (or (eq (car clause) 'otherwise) 
( i f (atom (car clause) ) 

(eq «machi ne-vers ion* (car clause)) 
(merq smachine-versi on* (cap clause)))) 
(return (cadr clause))) 
final ly 
_„_ (ferror nil "No c lau se in nAC HIN£*VERS1 0N-CAS£ for ^S" »aa chin e*version«) ) ) 
;;; Flow Of control ■icrot 

;If you uant to knou what the available tests are^ don* t look at these lists, 
{took at th« aacros £>«tou. There are aore poesibt I i ties than you think. 

I There Brm also soae !0 and GC related skip conditions uhtch F» leaving out for nou 

;Skip (choose one of two next instruct ions) 

(evai-when (eval load cocnpt (e) 

(def const vai id-skip-condi tions M jAdd wore as needed... 

;Co«pari8on8 of 28, 32, 34 bit fields (using X-Y-1 ALU function) 

aqua I -pointer not-equal -fixnum not-equal-typed-polnter 

:Unsigned comparisons, 28 and 32 bit fields (using X-Y-1 ALU function) 

not-greater -po inter not-greater-f i xnum-uns i gned 

;Type filter, cdr-code filter 

type-condition tbus-not-f ixnuia not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3 

;Ueird kludges 

ybu8-31 ;For di vie ion 

alu-31 alub-0 not-lbus-dev-cond »c-cond not-ctos-cane-from-i fu 

;One-argu»ent ALU-status condl t ion 

(defnacro defalucondi t ionl (name ekip-cond-name sense alu-func) 
(or (meaq skip-cond-naae valid-skip-conditions) 

(ferror nil "^S not a valid skip condition in ^S" sklp-cond-naae naoe)) 
(or (aeaq sense '(true false)) 

(ferror nil "*S not a valid skip sense in *S" sense naae)) 
•(defaicro ,naiie (opnd) 

(aake-aicpocondi tion ', ekip-cond-name *, sense 
(get-to-obus32 , (selcctq alu-func 
fX 'opnd) 

(X-1 ••(!. .opnd)) 

(otherwise (retch "Unrecogntred ALU function: *S — defalucondi t ionl' 
alu-func))})))} 

;Two-argunent ALU-status condition 

(def macro defalucondi tion2 (name skip-cond-name eense alu-func rever ee-a I u-func) 
(or (aeaq skip-cond-naae va I id-skip-condi tions) 

(ferror nit "-S not a valid skip condition in *rS" sk i p-cond-naae naae)) 
(or (aeaq sense '(true false)) 

(ferror nil "*S not a valid skip sense in ^S" sense name)) 
•(defaicro ,naae (x-opnd y-opnd) 

(aul tiple-value-bind (operand-code operands-reversed) 
(get-to-xbus-and-a!ub x-opnd y-opnd) 
(aake-microcondi tion \ skip-cond-name 

(if operands-reversed \ (cdr (assq sense '((true . false) (false . true)))) •.sense) 
(alu-paraiyze operand-code 

(a i u-a i cr i ns true t i on 

(if operands-reversed \ rever se-a I u-func *, alu-func) ))))) ) 

; Commutative two-argument ALU-status condition 

(def macro def alucondi t ion-coamutat i ve (name skip-cond-name sense alu-func) 
(or (aemq Ekip-cond-name valid-skip-conditions) 

(ferror nil "•^S not a valid skip condition in -vS" sk i p-cond-naae naae)) 
(or (memq sense Mtrue false)) 

(ferror nil "-S not a valid skip sense in •'S" sense name)) 
(defaicro .naae (x-opnd y-opnd) 

(aake-aicrocondi tion *, skip-cond-name \ sense 

(alu-paratyre (get-to-xbus-and-alub x-opnd y-opnd) 
(a i u-tt i cro i ns true t i on \ a I u-func) ) ) ) ) 

? Two-argument arithmetic comparisons 

(defalucondit ion-commutative equal-pointer equal-pointer true X-Y-1) 
(defalucondition-comautative equal-fixnum not-equal -fixnum false X-V-l) 
(defalucondi tion-commutative equal-typed-pointer not-equa/-typed-pointcr false X-Y-l) 
(defalucondit fon-commutative not-equal -pointer equal-pointer fa lee X-Y-1) 
(defalucondi tion-commutative not-equal-f ixnua not-equai-f ixnua true X-Y-1) 
(defalucondi tion-comoutative not-equa!-typcd-pointer not-equal-typed-pointer true X-Y-1) 
{defalucondition2 greater-pointer not-greater-pointer false X-Y-1 X-Y) 
(defalucondttion2 greater-f ? xnum-uns ioned not-areater-fi xnum-uns i gned false X-Y-1 X-Y) 
(defa uconditjong greater-f ixnua not-grcater-fi xnum-uns i gned false X-Y-l-signed X-Y-signed) 
defa ucondit)on2 greater-or-equal-pomter not-greater-pointer false X-Y X-Y-1) 
idefalucondt tion2 greater-or-equal-f ixnua-unsigned not-greater-f ixnua-unsi gned false 

A— Y A— T— 1/ 

(defalucondi tion2 greater-or-equal-f ixnum not-greater-f i xnum-uns i gned false 
X-Y-signed X-Y-1-eigned) 
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idefalucondi t ion2 !ecser-po inter not-greater-pointer true 
(defaiucondi t ion2 lesser-f ixnum-unsigned not-greater-f ixr.L 
(defalucondi t ionZ Icsser-f ixnum no t -nr ea t cr- f ixnum-unsi one 



X-Y X-Y-1) 
-urn-unsigned true X-Y X-Y-l) 
. - ..^.._ ^.-greatcr-flxnum-unsigned true X-Y-aigned X-Y-l-signed) 

(defalucondi tion2 lesser-or-equal-pointer not-greater-pointer true X-Y-I X-Y) 
Idefalucondi tion2 ieeser-or-equal-f ixnufn-unaigned not-greater-f ixnum-unslgned true 

A— Y— i A— 1/ 

(defalucondi tion2 teccer-or-equa l-f ixnum not-greater-f ixnum-uneigned true 
X-Y-1-signed X-Y-signed) 

;0ne-2rgument arithmetic test 
defalucondi tionl zero-ftxnum not-equal-f ixnum false X-1) 
(defalucondi t lonl not-rero-f ixnun; not-equal-f ixnum true X-1) 
: These two can be done in either the ALU or the YBUS 
; defaluconcJittonl mi nus-f i xnum aiu-31 true X) 
; (defalucondi tioni plus-or-zero-f ixnum alu-31 false X) 
(defnicro ainue-fixnua (opnd) 
Ciet ((data (sicroexpand opnd))) 
(if (can-get- to-ybus data) 

(nake-fflicrocDndi tion 'ytJue-Sl *true (get-to-gbus data)) 
(■ake-»icrocondi tion 'alu-Sl 'true (get-to-obus32 data))))) 

{def»icro plus-or-rero-f ixnum (onnd) 
(let ((data (Bicroexpand opnd))) 
(if (can-get-to-ybus data) 

(■ake-Bicrocondt ticn *ybu5-31 'falea (get-to-ybus data)) 
(Bake-nicroccndi tion *alu-31 'false (get-to-obus32 data))))) 

(dcfatucondt tionl ■inus-or-zero-f ixnum not-greater-f ixnum-unsigned true X-1) 
(defalucondi tionl plus-fixnum not-greater-f ixnu»-unsigned false X-l) 

(defalucondi tionl '•inus-or-zero-f ixnum alu-;51 true X-1) 
(defalucondi tionl ptus-fixnua atu-31 false X-1) 

(defalucondi tionl •inus-or-zero-f ixnum not-alu-31-or-c3rry-32 true X-1-signed) 
(defalucondi tionl plus-fixnua not-aiu-31-or-carry-32 false X-l-signed) 

;Logica! tests 

(defmicro bit- test (x-opnd y-opnd) 

(•ake-^icrocondi t ion not-equal-f ixnum * true ;i.e» not -1 
(get-to-obus32 MIognand , x-opnd , y-opnd)))) 

;Same for 28-bit operands 

(defmicro bit-test-pointer (x-opnd y-opnd) 

(make-Bicrocondi tion 'equal -pointer false ;i«e. not -1 
(get-to-obus32 Mlognand .x-opnd , y-opnd)))) 

(defmicro Idb-bit-test (y-opnd bit-number) 
(make-microcondi t ion 'alub-Q 'true 
(paralyze (get-to-ybus y-opnd) 

(if (eq bit-nuaber 'byte-r) 

Don't care how many bits in the byte, and can't use cond. Hence byte-s 



Maicroinstruct ton byte-func (Idb bute-r byte-s)) 

'(•icroinstruction byte-func (Idb ,(iogand (- 48 bit-nu«ber) 37) 1)))))) 

(defmicro bit (byte-field) 

(let ((data (nicroexpand byte-field) ) tea) 
(if (and (eq (car data) microdata) 
(eq (cadr data) *alub) 
(setg tea (get (caddr data) 'byte-func)) 
(eq (car tesi) ' Idb) 
(equal (caddr tem) 1)) 
(aake-microcondi tion 'alub-8 *true (caddr data)) 
(retch "^-S — ^S is not a single bit datua" byte-field data)))) 

(defmicro all-ones (computation) 

(aake-aicrocondi tion not-equal-f ixnum 'false 
(get-to-obus32 computation))) 

;Ueird condi t ions 
(defatoraicro ybus-31 

(microcondi t ion ybus-31 true nil)) 

;Alternate name for carry out of bit 31 of ALU 
(defatomicro aiu-carry 

(microcondi tion not-greater-f ixnum-unsigned false nil)) 

(defatomicro micro-stack-ewpty 
(ffi i cr 0-3 tack-eirp ty-k I udge) ) 

(defmicro micro-stack-empty-k ludge 
(or (eq «machine-version» 'proto) 

(retch "micro-stack-empty doesn't exist any more")) 
(microcondi tion not-ctos-came-from-i fu false nil)) 

(declare (special «cdr-code5* »data-types«)) ;from sysdef 
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(defnicro data-type? (val ftrest types) 

(nake-microcondi t ion •type-condition * true 
Mparallet , (cjet-to-abus val ) 

(ancpoinstruction type-map {(,(copylist types) cond) ) ) ) ) ) 

(defratcro not-data-type? (va! drest types) 
imake-fticpocondi tion 'type-condition 'false 
iparallel , (oet-to-aous val) 

(Bicpoinstruct ion type-map ((, (copy list types) cond)))))) 

;ne-3ing rules for type maps: 

;Ncte tnot the trap number overlaps uiih the pointer and cond bits. 
.tr.j, w ,en rergmg, anything that specifies trap overrides the pointer 
;a..c ccnd bits from uhat i t -i s being merged with. Also, only one trap 
;«t a tine can be specified; there it a priority order inn which says 
;uho gets control uhen both saps specify traps. Invisible pointers 
;have priority over bad type traps. 



;trap-2 is invisible pointer (highest priority) 

;trap-0 is bad data tupe 

;trap-l, trap-3 not defined yet, ao I just stick the» in at the end. ' 

(defconst trap-priority-order ' (trap-2 trap-8 trap-1 trap-3)) 

(declare (special »undupl icated-data-types«) ) ;in UUX 

(defprop type-raap merge- type-»aps Berge-f ields) 

(defun •erge-type-maps (mapl «iap2) 

(loop uith (condl condZ pointerl pointcr2) « nil 
for type in «undupl icated-data-tuoes* 
as out! • (type-ffap- lookup type mapl) 
as out2 - (type-ciap- lookup type «ap2) 
as trapl • (type-«ap-trap? outl) 
as trap2 - (type-map-trap? out2) 
as output » 

(cond ((and trapl tr«p2) (if (< trap2 trapl) out2 outl)) 
(trapl outl) 
(trap2 out2) 
((nui i outl) out2) 
((nut \ out2) outl) 
((equal outl out2) outl) 

(t '(cond pointer))) ;both it only other potsibilitu 
when output 

unless (loop for ent in map 

when (equal (cdr ent) output) 

return (rplacd (last (car ent)) (neons type))) 
collect (cons (ncont type) output) into map 
unless trapl 

do (if (memq 'cond outl) (setq condl t)) 

(if (menq 'pointer outl) (setq pointerl t)) 
unless trapZ 

do (if (memq 'cond out2) (setq cond2 t)) 

(if (memq 'pointer out2) (tetq pointer2 t)) 
f i na t I y 

(if Tor (and condl cond2) (and pointerl pointer2)) 

(retch "Conflict for cond and//cr pointer field: '^S ^S' 
mapl fflap2)) 
(return map) )) 

(defun type-map-trap? (out) 
( loop for K in out 

when (f ind-posi tion-in-i iat k trap-priority-order) 

return it 
unless (memq x ' (cond pointer)) 

do (retch '-..S — garbage in type map output ^S" x out))) 

(defun type-map- lookup (type map) 
(loop Tor (types . outputs) in map 

when (memq type types) return outputs)) 

(defmicro cdr-code? (val cdr) 

(wake-microcondi tion (nth (cond ((numberp cdr) cdr) 

( (f ind-posi tion-in- I ist cdr «cdr-codos*) ) 
(t (retch "*S invalid cdr code" cdr))) 
(not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3)) 
false 
(get-to-abus val))) 

(defmicro not-cdr-code? (val cdr) 

(make-ffiicrocondi t ion inth (cond ((numberp cdr) cdr) 

( (f ind-posi t ion- in-f t St cdr «cdr-codes«) ) 
(t (retch "*.S rnvaiid cdr code** cdr))) 
• (not-cdr-8 not-cdr-1 not-cdr-2 not-cdr-3)) 
true 
(get-to-abus val) 1) 

(defmicro not (bred) 
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(seta pred (mi croexpand pred) ) 

tor (and (listp pred) (eq (car pred) 'inicrocondi t ion) ) 

ferror ml Argurrcnl to NOT expanaed into ~S which is not a microcondi t ion") ) 
(or metriq (caddr pred) Mtrue false)) 

.(ferror nil "Invalid sense in ^S" pred)) 
tm.crocondition , cadr pred) ,(if (eq (caddr pred) 'true) Valse 'true) 
, (cadddr pred))) 

*'lnl M'tun".^*?^ '"'d^le^o^ a eequence and it splits the flow into 
:?ho.. ;: ? P2ths. wh.ch are sequences or single instructions. If 
•NMp th^ ?^;ti'^^ m*'"^ "^ the sequence the flow is assumed to rejoin. 
"u^trp tA" ^ l!f .2- a"^"JTediate sequence you may also say "(goto tag)" 
•u-'' u-^ufc rrt th!^^i"^ do ,ncd by 3 dofucr^de. If you said^MjSnp tagf- 
^^^inixr AlcnV S'Ln «*^^ct,but one cycle slower. The assembler copies 
. .nsir^^T.cns as necessary to implement this. You way also say (drop- through) 
; to avoid 9ettin5 grossly deep in indentation in tha source code, 
(defeicro jf (pred true false) 
(let» ((test (■icroexpand pred)) 

(skip (cond ((neq (car test) 'microcondi t ion) 

(retch "-^S expandod into --S, not a valid aicrocondi tion" 
prc6 test)} 
((memq (cadr test) val fd-eklo-condi t ions) (cadr test)) 
(t (retch "-^S invalid skip condition in *S** 
,., , , , , (cadr test) pred))))) 
Ctf (eq (caddr test) 'false) (psetq true false false true)) 
(paralyze 

(cadddr test) 

*(eicroinstruct ion ccnditton ,skip 

skip-true-sequence • (mlcroexpand-i f true) 
skip-faise-sequence , (eicroeKpand-i f false))))) 

:The value of the skip-xxx-scquence field is a microinstruction, a 
/!!'f'"°®®^"*"*^®' ® defucode tag, or nil meaning drop-through, 

(e^a'inrS^fSfnr^l^ninS^Ti .n '^t^^^ 9°^°^ drop-through which aren't defmicros 
isetq form (microexpand form)) • however microexpand is known not to comolain 
Ccond (and (not (atom form)) (- (length form) 2) (eq (car form) °SStS°) =°=P'^'" 
(cadr form) ) 
((equal form * (drop- through) ) 
nil) ^ 

(t form))) 

;Construct a microcondi t ion out of a condition name and some microcode. 
:The microcode is expanded now to make life simpler and to make 
;the backtracmg come out right. 
(dafun make-microcondition (ccndition sense code) 
(let ((expcode (microexpand code))) 
(if Cor (atom expcode) 

(not (memq (car expcode) ' (microinstruct Ion mtcroeequence)) ) ) 
irerror ml not microinstruction in microcondi t ion: *S «« -vS" 
code expcode) ) 
tor (memq condition valid-skip-conditions) 

(ferror nit "^S is not a valid skip condition" condition)) 
(or (memq sense '(true false)) 

(ferror nil "^S is not a valid skip sense" sense)) 
(microcondi t ion .condition .sense .expcode))) 
ti; Data type checking and other trapping 

llhiS I! ?hI^.!yP? °^''•' '? "°< o"« c>f the specified types. 

;tupe will be printed" '^■* argument of a non-oiatchino 

isiiq^rRiPT r® ■'■'"^V argument to various instructions: 
;T|!E^isTAC<°^S?%h^?;;gr??ie%'u^c'tl^^ a'-S— 1(5) to an array function; 

:?nItIn-''1^^;I^^^ for instance stuff; 

•ISar^?.S'?"'J-^':3-type (location°vS? «re§t typU)^^'' 
(parallel , (get-to-abus val) --w^' 

C.croin.truction type-.ap (( (types-ather-than types) trap-0)) 

error-table (urong- type-argument .location .types)))) 
'Z°Z ?'"P'« cases, specify location as NIL 
(defmicro check-data-type (va( irest types) 
(chech-arg-type nil ,va( . .types)) 

!«pecifild'?ypiJ:'' '*'*^-^"P« ^--^P " ^»'"« '• oi one of the 

*'^ip';r^;?i2?^fTj^?!;^:igj\n,r^''-"^- *^"^ *«""' 

(a. cro instruct ion type-wp ((.(copylist types) . trap-naae) ) ) ) ) 
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(defun types-other-than (types) 
;;I feel bad about (check-data-type foo fixnum) trapping everything, 
(loop for type in types 

unless (memq type Jkundupl icated-data-types*) 

do (retch "You have invalid data type *-$** type)) 
(loop for type in *undupticated-data-types* 
unless (memq type types) 
col lect typel) 

; Genera I "higher-level " traps. Any condition on the skip condition 
;«ultiplexor may be selected, and true or false aay be selected. If the 
•condition ts satisfied the machine traps to the next-microinstruction 
;address. expressed here as either a goto or a Microsequence as uith IF, 
(defmicro trap- if (pred trsp-sequcncei 
(i f (eq pred ' true) 

(setq pred * (cdr-code? (a-conetant 0) 8))) ;— - Somathing better? 
(let» ((test (microexpand pred)) 
(trap- if 'condi t ion- true) 
(cond (cond ((neq (car test) 'tiicrocondi t ion) 

(retch "•^S expanded to *S, not a vaTid ■icrocondi tion" 
pred test)) 
( (Kenq (cadr test) val id-skip-condi t tons) (cadr test)) 
(t (retch "*S invalid skip condition in -*S" 
(cadr test) pred))))) 
(if (eq (caddr test) *fatee) (setq trap-if 'condition-false)) 
Mparatlel 

.(cadddr test) 

(•icroinstruct ion condition ,cond 

trap-enables (, trap- if) 

trap-sequence , (mtcroexpand-i f trap-sequence) 

,«(setectq cond 

;;-- — This may be over-conservative. These, condi t ions 
;; come out a little bit later than the others. 
((alu-31 equal-pointer not-equal-f ixnua not-equal-typed-pointer) 
'(speed stou-second-half))))))) 

;S imply eliiilnate duplicates. For nou.. at least, no compatibility issues* 
(defun (trap-enables merge-f icids) (enl en2) 

(append enl (loop for en in en2 unless (memq en enl) collect en))) 

:Can have a data type check at the same time as a transporter check 

;In that case, the wrong- tupe-argument prevails. The error handler can print a different 

;message if it finds an illegal data tupe than one that fails to match. 

(defprop error-table merge-error-tabte-entr ies merge-f ields) 

(defun merge-error-t2b!e-entr ies (errl errZ ^optional (error-p t) 4aux err tl err t2) 
(aetq errtl (car errl) 

errt2 (car err2) ) 
(cond ((equal errl err2) 
errl) 
((or (nu! I err2) 

(and (eq orrtl ' wrong-type-argument) (eq err t2 'bad-data-type) ) ) 

( (or (nul I errl) 

(end (eq errtl * Dad-data- tupe) (eq errt2 'wrong-tupe-argument) ) ) 

( (not error-p) 

'no-go) 
(t 
(retch 'Error table conflict: *S and *rS" errl crr2)))) 

(defun compatible-error-tabfe-entries (errl •rr2) 

^'^^'i.Jj^PrSQ iBerge-error -tabie-en tries errl e rr2 nil))) 
;The type sap for nor»aI arithmetic, which has cond for non-fixnum numbers 
tend bad-argument trap for non-numbers, 
(declare (special «arithme tic- type-map*)) jlnUUX 

j;; flicros for arithmetic traps 

{2-operand arithmetic instructions use this 

(defmicro check- fixnu»-2arg3 (a-opnd b-opnd drest exception-routines) 
(paralyze (get-to-abus a-opnd) 
(aet-to-bbue b-opnd) 
•Imicroinstruct ion 

type-map ,«ar i thmet tc-type-map« 

tr ap-enab I es ( type-cond 1 1 i on bbus-non- f i xnum) 

epec trap-i f-type-cond-or-bbus-not-f txnum 



error-table (wrong- type-argument any (rnumber))) 
(sake-ar i th-d i spa tch-m i cr o i ns true t i on except i on-rout i nes) ) ) 

;l-opcrand arithmetic instructions use one of the next two 
(defmicro check-f ixnum-larg-a (a-opnd Arest exception-routines) 
(paralyze (ast-to-abus a-opnd) 
Mmicroinstruction 

type-map , »ar i t hme t i c- 1 upe-map« 
trap-enables (type-condition) 
•pec trap-if -type-cond 

error-table (wrong-type-argument nt I (:nufflber))) 
imake-ar » th-d t spatch-m i cr o i ns truct i on except i on-rout i nes) ) ) 
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(deffcicro check-f txnu«-larg-b ^b-opnd Irett except ion-rout ines) 
(paralgze (oet-to-bbua &-opnd) 

*T»icro instruct ion tAsautne no type-cond bite eet in aap — — 
trap-cnabtcs (type-condition bbue-non-f ixnum) 
spec trap- i f-type-cond-op-bbus-not-f i xnum) 
(■ake-ar t th-d i epatch-* i cro i nstruc t i on except i on-pout i nes) ) ) 

(def«icpo check-f ixnu»-b (b-opnd Apeet except ton-poutr nee) 
(paralyze (get-to-bbua b-opnd) 

•(•icpo instruct ion ; Assume no type-cond bits eet in eap — — 
trap-enables (type-condition bbus-non-f ixnua) 
spec trap-if-type-cond-op-bbus-not-f ixnum) 
(and exception-routines 
•(aicroinstpuct ion 

next-Bicpoaddpese , (nicpoexpand exccption-routinee))))) 

;Tpap if opnd is of any of the named types ^ and do an apithaatic dispatch 
;into the trap poutine. This is Bainfy for EQL. 

(defaicro check-data-type-and-di snatch (opnd-and-types fircst exception-pout inea) 
(let ((opnd (car opnd-and-tupes)) 

(types (cdr opnd-and-types))) 
(paralgze (oet-to-abus opnd) 
•(■icroinstPUCtion 

type-nap ((.types cond)) 
trap-enables (type-condition) 
spec tpap-if-type-cond) 
(vake-ap i th-d i epatch-n i cpo i ns tpuc t i on excep t i on-rout i nee) ) ) ) 

;Arithsetic trap dispatches on AeUS<33:32>|BBUS<33:32> 

:3 m either field can't happen, if a type check uas done 

{Unfortunately this isn't really true, since Bbus type checking incomplete (use OTHERWISE) 

(declape (special «api thoietic-trap-dispatch-cuee-alTet*)) ;inUJX 

;nake up a nicpoinstpuction that eithep diepatches op doesn't depending on 
;uhethep the apithmetic tpap exception routinee consist of «ore than 
;just an otherwise clause. 

;Uith no exception poutines at all. any exceptfon is an epror. 
;The caller is assumed to provide the trap enables, nerging ui I t switch 
\l^.^^^^'^^*^^^^^^^-^rap-ent> and supply the uagic-numbep bits as needed. 
idef un make-ap t th-d i epatch-m i cpo i netruct f on (except i on-rout i nee) 
(let ((disp (expand-dispatch-clauses exception-routines 

, ^ ,, ,, _,. , «arithmetic-trap-dispatch-cuee-alist«)}) 

(cond ((nul I dtsp) 




fop lack of Bbus type check 
iepatch 
apith-trap-dispatch-tablo (arith ((3 7 13) error-trap) 
/..,... ^ ,. . • .disp))) 

(t leicroinstruction spec ar i thmet tc-trap-wi th-diepatch 
— arith-trap-dispatch-table (arith . ,disp)})))) 

;;; "Data Processing* 

;Construct a »icrodata out of a data location and eoee •icrocode. 
;The eicrocode is expanded nou to sake life siapler and to sake 
;the backtracing come out right, 
(defun Bjake-nicrodata (iocatton code) 
(let {(expcode (nicroexpand code))) 
(if (or (atom expcode) 

(not (meraq (car expcode) • (aicpoinstpuction nicposequence)) )) 
(fcppor ml 'not aicroinstruct ion in eicrodata: -^S •- ^S" 
^, . code expcode)) 

•(■icrodata .location .expcode))) 

;The valid 'places' for data are ABUS. BBUS. XBUS, YBUS. ALUB, and OBUS 
;naybe aope ui I I be put m latep 

;Discapd the result of a eicrodata, just perform the aicrocode. 
(defnicro for-effect (val) 
(sctq val (■icrosxpand val)) 
(cond ((atom vat) val) 

Uep (car val) 'aicrodata) (caddr val)) 

Heq (car val) 'aicrocondi t ion) (cadddr val)) 

(t val) )} 

: Routines which understand the various bus routes 

;Put data on obus. Returns an instruction. 

'(SefSn*glt*-;oiobil3r(^o?;ir'"*"'' *° «"* *'^' "^ ^ "■'*•' "-^ *^« '^ ^'O*^ *-3 "'♦• 

(let* (Ubacktrace* (cons Mget-to-obus32} «backtrace«) ) 
(data (Biicroexpand for»>)) 
(if (not (and (not (atc«data)) 

(eq (car data) 'wicrodata) 
/ X ^ «r* (iiemq (cadr data) ' (abus bbus xbus ybus alub obus)))) 
(retch Cannot get data onto Obus: *-S — *S" for» data) 
(let ((code (caddr data))) 

(if (eq (cadr data) 'obus) ;If not already on obus. put it there 
code 
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(paralyze 
code 
(selectq fcadr data) 

(abus * (a icro instruct ion xbus abus 

alu xbu9)) 
<bbu9 • (Bilcpoinstruct ion ybus bbus 

bute-func ybus 
alu atub)) 
(xbus •(ictcroinstruct ion alu xbus)) 
(ybus * (■tcroinstruct ton bute-func ybus 

alu alub)) 
(alub Msicroinstruction alu aiub)}))}}})) 

;Sa»e but transfers ail th.5 ^it» (not just tou 32) 
(cefun get-to-obus (form) 

(!et« ((«cbacRtrace» (cons * (get-to-obus) sbacktrace*)) 
(data (nicroexpand form)}) 
(if (not (and (not (atom data)) 

(eq (car data) 'nicrodata) 

(mefflq (cddr data) * (abus bbus xbus ybus alub obus)))) 
(retch "Carnot get data onto Obus: *S -• ^S' form data) 
(let (iccde (caddr data))) 

(if (iaq (cadr data) 'obus) ;If not already on obus* put it there 
code 

(paralyze 
code 
(selectq (cadr data) 

(abus Mnicroinstructton xbus abus 

alu xbus 

; f orce-obae<35-34> abus ?wil! default 
tforce-obu»<33-32> abus $uill default 
J) 
(bbus '(microinstruction ybus bbus 

bute-func ybus 
alu alub 

f orce-obu8<33-32> bbus) ) 
(xbus Mmicroinstruction alu xbus)) 
(ybus * (nicroinstruct ion bute-func ybus 

alu atub)) 
, (atub '(microinstruction alu atub))))))))) 

(defun get-to-abus (form) 

(let» ((^backtrace* (cons '(get-to-abus) ^backtrace*) ) 
(data (microexpand form))) 
(if (not (and (not (atom data)) 

(eq (car data) *microd3ta) 
(eq (cadr data) *aous))) 
(retch "Data not accessible on Abus: ^^S -- -vS" form data) 
(caddr data)))) 

(defun get-to-bbus (form) 

(let* ( («backtrace» (cons ' (qet-to-bbus) srbacktrace») ) 
(data (microexpand form))) 
(if (not (and (not (atom data)) 

(eq (car data) 'microdata) 
(eq (cadr data) 'bbuc))) 
(retch "Data not accessible on bous: «S •• '^S" fora data) 
(caddr data)))) 

(defun get-to-xbus (form) 

(iet» ((^backtrace* (cons * (get-to-xbus) stbacktrace*) ) 
(data (microexpand form))) 
(cond ((or (atom data) (neq (car data) *nicrodata)) 
(retch "Not microdata: -^S -• -*S" form data)) 
((eq (cadr data) *xbus) 
(caddr data)) 
((eq (cadr data) *abus) 

(paralyze (caddr data) Mmicroinstruction xbus abus))) 
((eq (cadr data) 'bbus) 
(paralyze (caddr data) Mmicroinstruction xbus bbus))) 

(retch "Data not accessible on Xbus: ^^S »• ^S" form data))))) 

(defun get-to-ybu5 (form? 

(Iet» ((»bacKtrace» (cons * (get-to-ybus) «backtraco«) ) 
(data (microexpand form))) 
(cond ((or (atom data) fneq tear data) 'microdata)) 
(retch "Not microdata: *S -- ^" form data)) 
((eq (cadr data) *ybus) 

(caddr data)) 
( (eq (cadr data) 'abus) 

(paralyze (caddr data) Mmicroinstruction ybus abus))) 
((eq (cadr data) *bbus) 
(paralyze (caddr data) Mmicroinstruction ybus bbus))) 

(retch "Data not accessible on Ybus: ^S •• «S" form data))))) 

(defun gct-to-alub (form) 

(let» ((*back trace* (cons Moet-to-alub) «backtrace«) ) 
(data (nicroexpand foro))) 
(cond ((or (atom data) 
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(neq (car data) *nicrodata> 

(not (memq (cadr data) * (abus bbus ybus aiub)))) 
(retch "Data not accessible on ALUB: •'S •- -^S** form data)) 
((ea (cadr data) 'aiub) (caddr data)) ; Already there 
(t (paralyze jGet it there through ehift/oask 

' ^et-to-ybus data) 

icro instruct ion byte-func ybus)))))) 



(get- 
MBit 



(defun can-get-to-xbus (data) 
(cond ((or (atom data) (neq (car data) *»icrodata)} 
(retch **Not microdata: -vS" data)) 
(t (aeisq (cadr data) * (xbue abus bbus))))) 

(defun can-get-to-ybus (data) 

(cond ((or (atom data) (neo (car data) 'Bicrodata)) 
(retch *'Not microdata: ••S" data)) 
(t (memq (cadr data) '(ybus abus bbue))))) 

(defun can-get-to-atub (data) 

(cond ((or (atom data) (neq (car data) *flicrodata}) 
(retch "Not microdata: *^S" data)) 
(t (memq (cadr data) * (atub ybus abus bbus))))) 

;Fir9t value is code, second is t if form2 it on Xbus, nil if feral is 
(defun get-to-xbus-and-a(ub (foral form2) 

(let» ((«backtrace« (cons ' (get-to-xbus-and-aJub) sbacktrace*)) 
(datal (microexpand forml)) 
, (data2 (microexpand formZ))) 
(cond ((or (atom datal) 

(neq (car datal) 'inicrodata) 

(not (rncmq (c2dr datal) * (abus bbus xbus ybus alub)))) 
(retch "Data not accessible: *S -• *S" forml datal)) 
((or (atom dataZ) 

(neq (car dat32) *»icrodata) 

(not (memq (cadr data2) Mabus bbus xbus ybus alub)))) 
(retch "Data not accessible: *S -- -S" for«2 data2)) 
((eq (cadr datal) 'xbus) 

(values (paralyze (caddr datal) (gst-to-alub data2}) nil)) 
((mev.q (cadr datal) ' (ybus dlub)) 

(values (paratuze (get-to-alub datal) (gat-to-xbut data2)) t)) 
((eq (cadr data2) 'xdus) 

(values (paralyze (get-to-alub datal) (caddr dataZ)) t)) 
((memq (cadr data2) '^(ybus aiub)) 

(values (paralyze (aet-to-xbus datal) (get-to-alub data2)) ni!)) 
((sJow-source-p data2) 

(values (paralyze (get-to-xbus data2) (get-to-alub datal)) nil)) 
(t jUnconslrained, pick arbitrarily 
(values (paralyze (get-to-xbus datal) (get-to-a!ub data2)) nil))))) 

;flegard all off-board sources as slou 
(oefun siou-6ource-p (datum) 
(Eelectq (cadr datum) 

abus (memq {net (caddr datum) 'abus) ' (ine«ory-data Ibus Biemory-data-force vma pc Bap))) 
(otherwise nil))) _ 

;Test uhether a given field of an instruction has a given value ^ 

;Shou!d this barf if the field is not specified at all? 
(defun fie I dp (code field value) 

(or (eq (car code) 'Bicroinstruct ion) 

(retch "**S not a » icro instruct ion - fiat dp* code)) 

(equal (get code field) value)) 

;Changc a piece of code according to specified field renamings a-list. 
:Renaming something to nil deletes it completely. 
(defun Bodify-code (code changes) 

(or (eq (car code) 'Bicroinstruct ion) 

(retch "-^5 not a Bicroinstruct ion - aodi fy-code" code)) 
(cons 'microinstruction 

(loop for (field val) on icdr code) by *cddr 
as change - (assq fietd changes/ 
when (not change) 

collect field and coMect val 
else when (cadr change) 

collect (cadr change) and collect val))) 

;nicrDCode version of setf 

(defBicro assign (original-destination or iginal-source &aux destination source) 
(setq destination (Bicroexpand original-destination) 

source (alcroexpand or iginal-source)) 
(cond ;; URITE-ONLY REGISTERS 
((eq destination 'xbas) 
(paralyze (oet-to-obus32 source) 

'iBicroinstruction spec load-xbas))) 
:For the temporary memory control, there is an inst register ue can write 
((eq destination inst) 
lor (mctrq *machine-ver8ion« '(sim proto)) 

(retch "Cannot assign to INST— it only exists inside the IFU!')) 
(paralyze (Qet-to-obus32 source) 

'IBicroinstruction spec ctear-stack-adjustBent)) ) ;code 7 

((or (atom destination) (neq (car destination) 'aicrodata)) 
(retch "^5 -- ^S^-Xis not a description of a valid data destination" 
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or i Q i na t -des t i nat i on dest i nat ion) ) 
{(and (ncq source •array-index-chi f t-ppo«) ;BYTE-R kludge 
(or (atoB source) 

(neq (car source) *»icrodata) 

(not (ncRiq (cadr cource) * (abus bbus xbus ybus aiub obus))))) 
(retch "^S -« *S^Xis not a description of data" 
original-source source)) 

;; A DESTINATIOr;S 

((and (eq (cadr destination) *abu9) 

(fie! dp (caddr destination) 'abus *»efflory-data} ) 
; Store into memory by putting source on obus and writing I bus dev 
;AIso must set up the aisem-ur i te-addr in case location naps into asea 
;User is responsible for doina start-aemory in parallel uith this 
(paralyze (get-to-obus source) 

(modifycode (caddr destination) *((abusnil} (aaea-read-addr nil))) 
(seicctq «machine-ver8ion« 

((pro to si a) ' (nicro instruct ion urite-tbus obut 

Ibus-dev-addr wri te-aenory 
amea-urite-addr (bus-address))) 
(otherutse * (a icro Instruct ion aaea-wri t«-addr (bus-address)))))) 
((and (eq (cidr destination) *abus) 

(fietdp (caddr destination) *»bus * fraae-pointer)) 
; Store into fraae-po inter by putting the source on the obus* and 
; asserting wr i te- frame-pointer 
(paralyze (get-to-cbu532 source) 

(aodify-ccde (caddr destination) *((abus nil))} 
Maicpoinstruction spec load-trap))) 
{(and (eq (cadr destination) 'abus) 

(fieldp (caddr destination) 'abus 'stacK-pointer)) 
; Store into stack-pointer by putting the source on the obus and 
; assert in." wri te-stack-po inter 
(paralyze (get-to-obus32 source) 

(nodify-code (caddr destination) 
*((abus nil))) 
_^. Malcrojnstruction spec load-stkp))) 

:This version for real aefrory control (TUC board) 
((and (eq (cadr destination) 'abus) 

(fieldp (caddr destination) 'abus *vma)) 
(if (aemq «machine-ver8ion« * (sim proto) ) 

(retch "There is no VflA register on this aachine**)) 
•c °''T«ri"*° ^"'^ ^^ putting source on obus and doing appropriate aea function 
;ror TnC, data can come from Obus or riemory 
(paralyze (get-to-obus32 source) 

(aodify-code (caddr destination) ' ( (abus ni I )) ) 
' (a icro instruct ion write- 1 bus 

,(if (and (Demg «machine-ver8ion« • (tac tnc5)) 
(eq (car source) 'aicrodata) 
(eq (cadr source) *abus) 



(fieldp (caddr source) 'abus *aefflory-data)) 
*aeffloru-data 'obus) 



... ftien write-vmaJ)) 

jmts version for temporary memory control (FEP board) 
((and (mercq »mach ine-vers i on* * (sim proto)) 
(eq (cadr destination) *abus) 
(fieldp (caddr destination) 'abus 'aaem) 
{fieldp (caddr destination) *aaea-r«ad-addr 2Sei).) 
;Stora into both hardware VflA and A-»aaory copy 
(paralyze (get-to-obusSZ source) 

(aodtfy-code (caddr destination) M(abus nil) 

(amea-read-addr amem-wr i te-iddr) ) ) 
•(a icro instruct ion write-aaea obus 
aem wr i te-vaa) ) ) 
((and (eq (cadr destination) *abus) 

(fieldp (caddr destination) 'abus 'pc)) 
(if (aemq «machine-version« '(sim proto)) 

(retch "There to no PC register on this machine")) 
:5toring into PC — for TtlC, data can coffie from Obus or Memory 
(paralyze (g8t-to-obus32 source) 

(modify-code (caddr destination) '((abus nil))) 
(selectq «Bachine-vcrsion* 
((tmc) 
'(a icro instruct ion write- 1 bus ,{if (and (eq (car source) 'aicrodata) 

(eq (cadr eource) *abus) 
(fietdp (caddr eource) 

*abus *ae»ory-data)} 
'aenory-data 'obus) 
aea aicrodevice 

Ibus-dev-addr ur i te-vaa-and-pc) ) 
((tmcS) 
' (a icro instruct ion write- 1 bus tCif {*nd (eq (car source) *aicrodata) 

(eg (cadr source) 'abus) 
(fieldp (caddr source) 

*abus 'aeaory-data)) 
'aemory-data 'obus) 
aea wr t te-vma 
spec ifu-control 
aagic 8 
aaqic-aask 3)) 
(otherwise (retch "Don t know how to assign to PC on *S yet' 
•machine-version*) ) ) ) ) 
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{{and {eq (cadr destination) 'abus) 

{fieldp {caddr destination) *abu8 *ameB)) 
;Store into amem by selecting the appropriate write address, putting 
; the source on the obus, and assertin9 write-anen. Forget the speed 
; specifier since there is plenty of ti«e for the write address calculation. 
;lf the write address must come froa the AURA field, UH wilt put the speed back in, 
(paralyze {get-to-obus source) 

{■odify-code (caddr destination) * { (amem-read-addr amem-wri te-addr) 

(abus nil) 
(speed nil))) 
* (Microinstruction ur ite*amea obus))) 

;; B DESTINATIOf.'S 

{(and (eq (cadr destination) 'bbus) 

(fieidp (caddr destination) "bbus *bmein)) 
;Store into bmem by putting source on xbus if possible, otherwise 
;on obus. selecting the appropriate write address, and asserting 
;write-bmen. Note that putting eofflething on xbus never precludes 
; later deciding to put it on obue too* when writing baea froa xbus 
;the high 4 bits come froa abus. 
(let ((code (modtfy-code (caddr destination) 

• ((bmea-read-addr baea-wr i te-addr) 
(bbus nil))))) 
;If writing the hard-to-wr i te locations, need spec function 
(if (< (get code 'baea-wr i te-addr) 3£9) 
{setq code (paralyze code 

•(microinstruction spec crocks aagic 18)))) 
;AnUA aeta plugged in later 
(tf (memq (cadr source) * (abus xbusT) 
(paralyze (get-to-xbus source) 
code 

* (microinstruction write-bmea xbus)) 
(paralyze (get-to-obus source) 
code 
* (a I cro instruct I on write-baea obus))))) 

;: BYTE-R and BYTE-S registers (write-only on pro to) 
((and (eq (cadr destination) 'alub) ;BYTE-S 

(fieldp (caddr destination) 'ybus 'ybus-crocks-2) 
(fieldp (caddr destination) 'byte-func '(Idb 10 5))) 
{paralyze (get-to-obus32 source) 

(modify-code (caddr destination) '{(ufcus nil) (byte-func nil) (spec nil))) 
•(microinstruction spec load-byte-s) J') 
((and (eq (cadr destination) 'alub) ;BYTE-R 

(fieidp (caddr destination) 'ybus 'ybus-crocks-D 
(fieldp (caddr destination) 'byte-func Mldb 18 5))) 
(paralyze (if (eq source 'array-lndex-shif t-prom) 

• (microinstruct icn magic 10 itagic-aask 18) 
(paralyze (get-to-obus32 source) 

•Taicro instruct ion aagic 8 aagi c-mask.lB) ) ) 
(fflodify-code (caddr destination) "(Tubus nil) (byte-func nil) (spec nil))) 
' (nicroinstruct ion spec load-byte-r) ) ) 

;; ALUB (BYTE) DESTINATIONS 
((eq (cadr destination) 'atub) 

;; Assign to a byte by putting the byte*s word on one bus (A or B) 
j; and dpb '"Q^the byte value into it froa the other bus, then assiantng 
;; t'le result back into the byte's word. -so'smng 

(let ((background-bus (get (caddr destination) •ybus)) 
(byte-bus (cadr source))) 
(if (not (or (and (eq background-bus *abu»> (eq byte-bus 'bbus)) 
/ * u -c* "*? (eq background-bus 'bbus) (eq byte-bus "abual))} 
(retch "Storing -S (on -^S bus) into -.3 (on^S bus)*-* 

cannot be done; one must be Abus and the other BBus" 
/I * // ortgmal-source byte-bus original-destination background-bus) 
(let ((word (aake-aicrodata background-bus 

(aodify-code (caddr destination) 
, ^ , ^ / . , '((ybus nil) (byte-func ni I)) ) )) 
trot (second (get (caddr destination) 'byte-func))) 
(siz (third (get (caddr destination) 'byte-func)))) 
(assign ,word , (oake-microdata 'obus 

(paralyze (get-to-xbus word) 

(get-to-ybus source) 
•(aicroinstruction 

byte-func (dpb ,{logand 37 (- 48 rot)) 
• siz 
■erge) 
alu alub 

f or ce-obus<33-32> , background-bus 
force-obu8<35-34> 

JnS^)n? background-bus 'abus) 'abus 8) 

(t (retch "I don't know how to store into this: ^S*X — *S" 
originaj-destination destination)))) 
; Referencing amem via the address arithmetic 
:Valid forms for addr ar^: 
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( frame-po i nter f i xnum) 
(stack-po i nter f i xnum) 
(■acrocode) 
f i xnum 
(constant val) 
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tbctween Q and 7777 I guess 
tacidress of constant to be a( 
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located later 



(def micro amcra (addr) 

Mnicrodata abus (microinstruction abus amen 

amem-read-addr ,addr 

^•(and (irstp addr) (neq (car addr) 'constant) 
Mepeed slou-f tret-hat f) ))) ) 



(defatoBicro address-operand 
(amee (macrocode))) 



;of a forBat-2 instruction 



;Aliou the obus to be referenced explicitly, for convenience in writing 
;code uhich stores into two destinations siaut taneously 
(defatomicro obus 

(microdata obus (microinstruction))) 



;Def*m(ng registers in amem or bmen 

; These forms define registers at specific locations 

;You can use these, but normaiiy they are just used by the SYSOEF stuff 

(def macro defareg-at-!oc (name location 

^optional initial-value (stmulatcr-tni tial-value initial-value)) 
(checK-arg location is Q location 7777) "a 12-bit number") 
Mprogn 'compi ie 

,mTlf ini tial-vatue •<(add-a-mefflory-va!ue , location , initial -value) )) 

,m(if simuiator-initial-vaiue '((acet ,srmulator-ini tial-value «a-Demory« .location))) 

(defprop ,name .location defareg-at-loc) 

(add-a-memor y-syrr.bo I ' , name , I oca t i on) 

JSfQ (si :record-source-f i le-natne ',natne 'defareg-at-loc) 

(eval-uhen (compile load evat) 

(add-atomicro ',narae Mmicrodata abus (microinstruction abus ametn 

inem-read-addr .location)))))) 

(dmfmacro defbreg-at-loc (name location 

&cpt tonal int tiat-vatue (simutator-ini tial-value ini tial-value) ) 
, (check-arg location is 8 location 377) "an 8-bit number") 
* (progn 'compi Ie 

.•Tif initial-value ' ((add-b-memoru-value .location .initial-value))) 

.•(if simulator-initial -value '((asef , Simula tor-ini tial-value »b-memoru« .location))) 

(defprop .name .location defbreg-at-loc) 

(aad-b-fflcmory-synbol * .name , locat ion) 

UQ (si :record-source-f i le-name '.name 'dcfbreg-at-Ioc) 

(eval-uhen (compile load evat) 

(add-atomicro '.name '(microdata bbus (microinstruction bbus bmem 

bmem-read-addr .location)))))) 



;Defining registers at variable locations 

;Note that if you do this after doing a defareg-at-loc of the sane name, 
;get the same register at the same location. This can be useful for 
;«pecifying initial values for registers set up by SYSDEF. 



you 



(defvar *next-defareQ-address») 
(defvar »defarcg-l imi t*) 
(defvar atnext-defbreq-address*) 
(defvar «defbreg-l imit*) 
(defvar »b-tefflp5-base« 3B5) 



; Anything from here up is a temporary, possibly 
; over lapped with other temporaries Isee UA) 
; except for the b-temp .., b-temp-3 series 



(defmacro reserve-scratchpad-mernory (first-a last-a ^optional first-b last-b) 
* (evat -when (compile eval) 

(setq *next-detareg-address* ,first-a 

«defareg-l imi t» . last-a) 
, (if first-b 

'(setq »next-defbreg-address« .first-b 
«dcfbreg-I imi t* , last-b)))) 

(defmacro defareg (name ^optional initial-value (simulator-ini tial-value initial-value)) 
(let ((location (or (get na-ne 'defareg-at-loc) 

(progl «next-defareg-address« 

(if (a «next-di3fareg-addre9s» »defareg-l ini t*) 
(ferror nil "Not enough A-memory reserved")) 
,^ (tncf »next-defareg-address«) )) ) ) 

(pronn 'cornpi Ie 

.•Tif initial-value ' ( (add-a-memcry-vatue , location .initial-value))) 

.•(if sifTulator-initial-value '((asot , simulator-ini tial-value «a-menory* .location))) 

(add-a-mcmory-symbol *,nafiie .location) 

tt^ ts I :record-£ource-f t le-name *,name 'defareg) 

(eval-uhen (compile load eval) 
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(add-atomtcro \nare 

•(■icrodata abus (micpornatruction abus amea 

amem-pead-addr , location) )))))) 

(defmacro defbreg (name ^optional initial-value (siniulator-ini t lal-value initial-value)) 
{let ((location (or (get name *defbrerj-at-loc) 

(progl *next-defbreg-addre5S* 

(if (£ «next-defbreg-addpe35» «defbreg-l imi t*) 

(feppor nit "Not enough B-memopy pesepved")) 
(incf «next-dsfbpeg-address*) ) ) ) ) 
(op (< 7 location 377) 

(fcppop nil "-vOcB is not a nopr.al B-iiemopy location, you don't want to put -vS thepe" 
location narro) } 
' (progn 'compi le 

,cTif initial-value * ( (add-b-mefnory-value , location , ini tial-vafue)) ) 
.•(if simutatop-tni t iaf-vatue *(taset ,Sfmu!atop-ini tial-vaiue *b-ner,opy* , location))) 
(add-b-memopy-synto 1 * , name » t ocat i on) 
<?Q Isi :recopa-souPce-f i le-name ',narae 'defbreg) 
(evai-when (compile load eval) 
(add-ato»icro \nafne 

(microdata bbus (oiicpoinstruction bbus bme* 

bmen-read-addp .location))))))) 

:Define B tempopapies. AH files' B-tenps go in the ssae •emory locations, 
(defnacpo def ine-b-tc»ps (&rest names) 
• (ppogn 'compi te 

. .(loop fop name in names as loc upfrom «b-temps-base* 

:: Note that location 377 cannot be used since it gets clobbeped 
when (a loc 377) do (feppop "Not enough B-temp space fop ^-S** name) 
nconc * ( (add-b-meniopy-suirbol '♦name , Joe t) 

#Q (sitpccord-so'jpce-f i le-name \name *def Ine-b-texps) 
(eval -when (compile load eval) 

(add-ato«tcpo ',name '(aicpodata bbus 

{»icro instruct ion bbus bmem 

bDe«-rcad-addr Joe)))))))) 

; These ape the values actually to be loaded into the hapduare 
(defvar «a-fflemopy-values* nil) 
(defvar *b-fflemory-values« nil) 

(defun add-a-memopy-value (location value &aux tem) 

(if (setq tera (assoc location xa-memopy-valucs*) ) (pptacd tern value) 
(push (cons location value) «a-pemopy-values») ) ) 

(defun add-b-memopy-value (location value &aux tern) 

(if (setq tem (assoc location «b-fflemGpy-vatues*) ) (rp I acd ten value) 
(push (cons location value) »b-memopy-values«) )) 

; These ape symbol tables fop the debuggep 
(defvar «a-memopy-Eymbol £« nil) 
(defvar *b-memopy-£ymbol e* nil) 
(defvap «o-temp-sytr.bol £« nil) 

(defun add-a-memopy-synbol (name location ^aux tem) 
(cond ((setg tern (assq name «a-memopy-8yribol s*) ) 
(op U tcdp tem) location) 

(fopinat cppop-output "-viUapning; *^ defined at both -^O^A and *0«A" 
name (cdr tem) location)) 
(pplacd tem location)) 
(t (if (setq tem (passoc location «a-memopy-symbol8«)) 

(fopwat eppcp-output "-^^S and *S at same address (*0«A)" 
name (car tem) I ocat ion) ) 
(push (cons name location) *a-flfemopy-8yinbol8«)) )) 

(defun add-b-memopy-symbo! (name location ^optional temp-p 4aux tem) 
(and temp-p (not (memq name *b-temp-8ymbol6*) ) 

(push name »b-temp-sur.boi s*) ) 
(cond ((setg tem (aijsq name sTb-memopy-symbots*)) 
(or (« (cdp tem) location) 

(fopmat erpor-output "^^AUarning: *A defined at both •OaB and *<0«B" 
name (cdr tem) location)) 
(pptacd tem location)) 
(t (and (setq tem (passoc location «b-memopy-symbo Is*)) 

(not (and temp-p (memq (cap tem) »:b-te:.:p-symbols*) ) ) 
(format cppop-output ''^^^S and -^S at same addpess (-^•B)" 
name (cap tem) location)) 
(push (cons name location) «b-memopy-sya:bols*) ) ) ) 

;Const3nts on the" A side. 

;The final assembly phase will allocate Amem locations fop these, 

;but for now ue just stick the constant in the amem addpess fop the Lispifiep 

(defmirpo a-constant (value) 

Mmicpodata abus (micoinstpuct ion abus arem 

amem-pead-addp (constant ,(evat value))))) 

;Constants on the B side 
(deffT.icro b-constant (value) 

Mmicpodata bbus (microinstpuct ion bbus bmem 

bmem-pead-addp (constant .(eval value))))) 

;The base pegisteps fop the amem addressing hapduape 
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(defatomicro frame-pornter 

iiricrodata aous (microinstruction abus frame-pointer))) 

fdefatoffiicro stack-pointer 

(ciicrodata sbus {microinstruction abus stack-pointer))) 

(defmicro increnent-stack-pointer 

• imicroinstruct ion stack-pointer increment)) 

(defmicro decrement-stack-pointcr 

* (microinstruction stack-pointer decrement)) 

;Explicit routing kludges (PARALLEL won't rewrite the code to make it compatiole) 
(def micro via-xbus (source) 

(make-mi crodata *xbus (get-tc-xbus source))) 

(defmicro via-ybus (source) 

(make-mi crodata 'gbus (gct-to-ybus source))) 

;The macro program counter, 

;This is a word address, with bit 31 selecting between the two 

;haifword3. The hardware supplies the tag when reading, and 

; looks at bit 31 when writing. The data type field is 68 cr 78. 

Cdefatomicro pc 
(pc-kiudge) J 

(defmicro pc-kludge 

(sclectq *machinc-ver8ion« 
( (sim proto) 

;; Use 2508«A, a location kludgitu known about.., 
' (mi crodata abus (microinstruction abus amem amcra-read-addr 2583))) 
(otherwise 
• (mi crodata abus (microinstruction abus pc))))) 

:To translate the PC into a 32-bit halfword index, rotate it left 1 
(defmicro hat fword-pc (nord-pc) 
•(rotate ,word-pc 1)) 

;To translate a halfword index into a PC value, rotate it right one place 
; then plug 3 into the high-order 2 data- type bits, selecting type B8 or 73. 
(defmicro word-pc (ha ! fword-pc) 
(caKe-mi crodata *obu5 

(paralyze (get-to-ubus ha I fword-pc) 

'(microinstruction byte-func (Idb 31. 32.) 
alu alub 
f orce-obu8<33-32> 3) ) ) ) ; dtp-even-pc/dtp-odd-pc 

;To translate a word address into a PC which points at the odd (second) 
; instruction in that word, a I i we have to do is «et the data type, 
(defmicro cdd-pc (address) 

'(set-type , address dtp-odd-pcJ ) 

;Tran5late a word address into a PC which points at the first instruction in that word 
(defmicro even-pc (address) 

•(set-type , address dtp-even-pc) ) 

;This kludge is to avoid conflicts fcr the magic number field 



(defmicro even-pc-except-38-throucjh-28 (address) 

(let ((dtp-code (f ind-posi t ion-in-i i st 'dtp-even-pc «dat3- types*) ) ) 
(«3ke-mi crodata 'obus 

• (parallel , (9et-to-obus32 address) 

(microinstruction force-obus<33-32> ,(tsh dtp-code -4)) 
(microinstruction maqic .(logand dtp-code 10) 

magic-mask 18))))) ; force-cbus<31> 

;Predicate for checking "low" bit of PC 
(defmicro odd-pc? (pc) 

(maKe-micrcc:;ndi tion 'a(ub-8 'true 

(paralyze (net-to-ybus pc) 

'Imicroinstruct ion byte-func (Idb 1 32.))))) 

;nacroinstruct ion fields that come in on the B side 
(def a torn i cro macro-unsigned- immediate 
(mi crodata bbus (microinstruction bbus macro-unsigned-immediate) )) 

(def atom i cro macro-c i gned- i mmed i ate 

(mi crodata bbus (microinstruction bbus macro-signed-immediatc)) ) 

;Two words of magic hardware fields 
(defatomicro ybus-crocks-1 

(mi crodata ybus (Microinstruction ubus ybus-crocks-1 

spec crocks-to-ybus))) 

(defatomicro ybu5-crocks-2 

(mi crodata ybus (microinstruction ybus ybus-crocks-2 

spec crocks-to-ybus))) 
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{defucode service-net-transmi t-done 

(assign net-b-temp Xnet-free- I i st) 

{parallel {start-oenorLi write physical Xnet-packet-being-transrai tted) 

(assign iiemoru-data (set-type net-b-temp dtp-fix))) 
(assign llnet-free- ! i st Xnet-packet-being-transmi tted) 
(assiqn Xnet-packet-bei ng-transmi tted (D-constant -1)) 
(paralte! (set-net-status Xnet-micro-status-idle) 

(jump service-net-idle))) 

;;; Read net status, and increment meters. If there was an error, throw the packet 
;;; auay, and wakeup the regular process 
(def ucode net-rece i ve-comp t et i on 

(start-nenory read physical Inet-control-address) 
( io-board-bug-delay) 
(nop) 

(assign net-dRa-temp Kenory-data) 

(if (bit-test net-dma-temp (b-constcnt (get *Xnsr-error-«ask 'sysconstant) ) ) 
(goto net-recei ve-error) 
(drop-through)) 
(assign net-doa-texp (+ Xnet-packet-bsinq-received 

<b-constant (f ield-word-of fset *ether-packet-f inal-pointer) ) ) ) 
(assign net-b-temp Xnet-mer.ory-address) 
(parallel (start-nemory write physical net-dma-tcr;p) 

(assign »emory-data net-b-temp)) 
;; Link onto received list 
(assiqn net-b-temp Xnet-received-I i ct) 
(parallel (start-memorLf write physical tnet-packet-being-received) 

(assign iiemory-data (set- type net-b-tcmp dtp-fix))) 
(assign Xnet-received-1 ist Xnet-packet-being-received) 
(assign Xnet-packet-being-received (b-constant -1)) 
(parallel (set-net-status Xnet-aicro-status-idle) 
(juEp service-net-idle))) 

(def ucode net-rece t ve-error 

;; Increment counters for the exact kind of error we received 
(if (field-bit net-dma-temp XXnsr-crc-error) 

(increment Xnet-crc-errcrs) 

"drr:p- through) ) 
(if (fieid-,:it net-dma-temp XXnsr-al rgnment-error) 

(increi::snt Xnet-al i gnment-errors) 

(drop-through) ) 
(if (fieid-bit net-dma-temp XXnsr-prearable-error) 

(increment Xnet-preambie-errors) 

(drcp-through) ) 
(if (fieid-bit net-dma-temp XXnsr-buf fer-overf low) 

( increment Xnet-buf ter-overf lowc) 

(drop-through) ) 
(jump reset-net-dma) ) 

(defucode net-transmi t-col 1 ision 

(start-memory read physical Xnet-control-address) 

( i o-boar d-Dug-de 1 ay) 

(nop) 

(assign net-dma-temp memory-data) 

;; Here increment meters 

(increment Xnet-col i ieions) 

;: If we have backed off too «any times, fail transmission 

(if (equal-f ixnum Xnet-next-backof f (b-constant (1- (Ish 1 (+ 2 15.))))) 

(goto net-transmi t-fai lure) 

(drop-through) ) 
;; riask for pseudo random number generation 
(assign net-b-temp (logand Xnet-next-oackof f (b-constant (1- (Ish 1 (+ 2 10.)))))) 

;; Kludging is because we dont have a b-temp to read ntcrosecond clock into 

(disable-tasking) 

(para! lei (disable-tasking) 

(for-effect (read-lbus-dev 36 0))) 
;; Backoff is mask & microsecond-clock 
(parallel (declare-memory-t iming data-cycle) 

(assign Xnet-backof f-count (logand memory-data net-b-temp))) 
t; Xnet-next-backof f <- (1- (^ 2 n+D) 

(parallel (assign Xnet-next-backof f (logtor (rotate Xnet-next-backof f 1) 

(b-constant 1))) 

(jump start-net-backoff))) 

(defucode start-net-backoff 

(set -net-status Xnet-micro-status-backing-of f ) 
(parallel '(start-memory write physical Xnet-control-address) 

I ... i^ssign memory-data (b-constant (get *Xnsr-backof f-start ' sysconstant) ) ) ) 
(parallel (start-net-dma backof f-t tf?ar) 
(jump device-service-end))) 

(defucode net-transmi t-fai lure 

(parallel (increment Xnet-transmi t-sbor ts) 
(jump reset-net-dma))) 
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(definstl Xnct-wakeup no-cperand 
(uakeup-net-scpvice) ) 

(defucode ini t iai ize-net 

(phys-»em-read (a-constont (get •net-addpe«a-l 'viptual-address) ) ) 
(assign Xnet-address-l «ernopy-data) 

(phys-mem-read (a-constant (get *nat-addPes8-2 'viptual-addpess) ) ) 
(paral lei (pctupn) 

(assign Xnet-3ddPes3-2 aetnopy-data) ) ) 

:; This is sepapate. since we dont have an extpa cycle 
(defraicpo uakeup-peceive-end- Sep vice 

* (paral let (assign service-task-requests 

(logiop scpvice-task-pcquests 

(b-constant (byte-fcask Slservice-pcceive-end) ) ) ) 
(uakeup-task Xdcv ice-service- task) 
}) 

;;; This is the peceive end of the network 
(defaicro check-packet-end 

• (if Ibus-dev-cond 

(paral lei (wakeup-receive-end-scrvice) 

(j'jrrp net-dma-dead) ) 
(drop-throughi i } 

(defucode nct-recetve-dwa 
;: Starts with iinet-b lock-pointer point inq to the dest-high 
(parallel (pcceive-dma Xnet-bicck-potntcr) 

(check-packet-end) ) 
(paral lal (extpa-t ime-to-dp i ve-lbus) 

(set-net-status Xnct-Bicro-status-receiving) ) 
;; Task twitch 
(papatlel (receive-dmaSnet-b lock-pointer nil) 

(check-packet-endJ ) 
;; Rewind pointer to dest-high 
(para Met (extra- 1 1 we- to-dr i ve- 1 bus) 

(assinn Inet-block-pointer (- Xnet-b lock-pointer (b-constant 2)))) 
(parallel (ctart-nemory read physical Inet-block-pointer) 

(assinn Xnet-blcck-pomter (1+ Xnet-biock-pointer) ) ) 
(parallel (start-memory read physical Xnet-block-pointsr) 

(assign Xnet-block-pomter (1+ Xnat-block-pointer) ) ; 
:; net-dma-temp is the first address word 
(assign net-dr.:a-temp memory-data) 

(if (not (equal-f ixnum (tdb memory-data 28 8) Xnet-address-2) ) 
(goto acdress-ffltss) 
(arop-through) ) 
(if (not (equal-f ixnum net-dma-temp Xnet-address-l) ) 
(goto address-miss) 
(goto net-accept-packet))) 

;;; Here address compapison failed, check for broadcast or promiscuity 
;;; net-dma-temp is the first address word 
(defucode addpess-miss 

(if (Idb-bit-test net-dma-tenip 7) 
(goto net-accept-packet) 
(cpop-through)) 
;: Here cneck fop promiscuity and goto NET-ACCEPT-PACICET 
(jump net-ignore-packet) ) 

(defucode net-ignore-packet 
(net-controt ni I t t) 

iset-net-status Xnei-micro-status- ignoring) 
;; Task switch 
(increnent Xnst- ignored) 
( term inat«-net-daa Xnet-micro-status- idle) ) 

(defucode net-accept-packet 
(net-control ni t t) 
(jump net-header-loop)) 

:;; Transfer the header into the packet block 

(defucode net-header- ioop 

(parallel (pecei ve-dma Xnet-block-pointer) 

(assign Xnet-block-pointer (1+ Xnet-block-pointer)) 
(check-packet-end) ) 
(paral lei (extra-time-to-dr ive-lbus) 

(assign !^net-word-count (1- Xnet-word-count) ) 
(if (not (»inus-f ixnum obus)) 
(noto net-header-loop) 

;; Aftep the header, the rev blocks follow directly 
(goto net-block-fetch-loop)))) 

::; Fetch next block pointer and count, and dma one word into it, 
;;; If there are no blocks left, return with data-overflow error 
(defucode net-block-fetch- loop 

(parallel (start-memory read physical Xnot-block-pointer) 

(assign Xnet-blcck-pointer (1+ Xnet-block-pointer))) 
iparallel (start-memory read phusical Xnct-b lock-pointer) 

(assign tnet-biock-polnter (1+ Xnet-block-pointer) )) 
iparallel (assign Xnet-memory-addpess memopy-data) 
(if (minus-f ixnum memopu-dota) 
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(goto net-data-overf iowJ 
(tirop-throunh) ) ) 
(parallel (assign Xnet-uorci-count (1- memory-date)) 
(jump net-block-loop))) 

;;; Transfer in all the uords in this block until packet end 
(deiuccde net-b I ork- ! oop 

tparal lei irecei ve-cir.3 Xnet-Demory-address) 

(asctcjn tne»-n:crory-addr2C3 (1+ Xnet-memory-address) ) 
(check-packet-enriJ J 
(para I lei (extra- ti me- to-^r i ve- 1 bus) 

(assign Xnet-word-count (1- Inet-wopd-count) ) 
(if (not (rainu5-f ixnum obus) ) 
(goto net-block-loop) 
(goto net-block-fetch-locp)) ) ) 

M Stcre additional-flags, in packet ue have not disraissed bu thia ootnt 
(defucode net-data-overflow ^ pumi 

;; increment a meter 

(teroinate-net-dDa Xnet-micro-status-idte t)) 

(defucode net-dma-dead 
(net-control ni I t) 

(j ump net-dma-dead) ) 

;;; Transmit side 

;; Thia is separate, since ue dont have an extra cycle 
(defaicro wakeup-tpansmi t-col I iaion-service 
Mparallcl (assign service-task-pequests 

(logiop scpvice-task-pcquests 

(defmicro check-transmi t-col I ision 
* (i f Ibus-dev-conri 

(uakeup-transmi t-cci t i si on-serv ice) 
(drop-thpough))) 

(defucode net-tpansmi t-dma 
(Btsrt-memopy pcad physical Xnet-contpol-addpcss) 
1 1 o-board-bug-de I ay) 
iaasign Xnet-mtaory-addresa (+ Xnet-packet-beinq-tpansmi tted 

(if (f.eld-bit memopy-data nnap';o?!:?^i;;Lin 'ethep-packet-dest-high) ) ) ) 

(gcto sui tch-to-pecei ve) 
(drop-thPough) ) 
(paral iel (tpansmi t-dma Xnet-memory-address) 

(assign Xnet-meKOpy-addpess (1+ Xnet-aemoru-addpesa)) 
(check-tpansmi t-coTi ision)) ^ auurcaa// 

(set-net-status Xnet-micro-status-transmi tt ing) 
;; Task switch ^ 

(assign Inet-b lock-pointer (+ tnet-packet-being-transni ttcd 

(b-constant 

(parallel (start-memory read phyii^Il'snSt^b^ocr.Jo'inlS?)-'"^''*-'""*-'-^''''^"''''' 

(assrgn Xnet-uord-count Tb-constant 2)) 
;: net-dma-temp is the address of the first users block 
tparal Iel assrgn net-dma-temp memory-data) 
(jump net-transroi t-b(ock-loop))) 



(defucode net-transmi t-next-block 




er))) 
cr))) 



. , - -smp memopy-data) 

(jump net-transTii t-biock-iocp) ) ) 



(defucode net-transmi t-block- loop 
(paraMel (transmi t-dma Xnet-memory-addrcss) 

(assign Xnet-memoru-address (1+ Inet-memory-address) ) 
f^, .. . c^«ck-transm.t-coTl ision)) y «"" b«; / 

(parallel assign Xnet-uord-count (1- Xnet-word-count) ) 
liT (not (minus-f ixnum obus)) 

(goto net-transmi t-block-Ioop) 
. ^ , , , , (dpop-thpough))) 
• tparaiie! assign Xnet-memopy-address net-dma-temp) 
(If Jminus-f ixnum net-dma-temp) 



(goto net-transmi tted-last-word) 
(goto net-transmi t-next-block)))) 



i=3efucode net-transmi tted- last-word 
:: 7!?*[].*^^''^?'^ ^«^e» the iast data word is in t 

^oarane. transm; t-dma Xnet-memoru-aadrcss t t) 
tc!-,ecK- tr ansm i t-co I I i a i on) ) 



the shift register, ue want 

word 
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(--or) 

:: Ta^K »ui tch 

:; Here the CRC is in the output shift pcf^tster so check for collision 

i let -net -status Xnet-micpo-status-transmi t-done) 
tcaralie! (trantmi t-d::3 ^tnGt-menioru-address t) 

(check-tranami t-col I tsion) ) 
(parallel (uakeup-net-service) 

{juap net-dma-dead)) ) 

:: ^e^e ue uant to suitch to receive mode if possible 
tCffw-crie -wi tch-to-recei ve 
:: Lr.ar5e to receive mode 
*?a-aMei istart-nemory write physical Xnet-controt-address) 

(assign ner;orvj-c!ata <b-ronstant (get 'ttnsr-pecei ve-start 'sysconstant) ) ) ) 
ita-iiiei (assign Xnet-Siock-pointer (+ (b-constant 

(f ieid-wopd-offset 'ether-packet-dest-high) ) 
tnet-packet-be i ng-rccc t ved) ) 
(if (ninus-f ixnum tnet-packct-be ing-recei ved) 
(jurno net-ionore-packet) 
(droD-throufih))) 
'*-; "- tnet-uord-count (I- (b-constant 2))) 
• w -a ti and uatt for first receive data 

"•^'* c- (sfft-net-status tnet-micro-status-receive-wai t) 

[.iH"P net-recetve-doa)) J 

;;; tnet-backof f-count has the count to back off (units ore 12.8 usee) 
;;; Check to see if packet is coming in 
(defucode backoff-timer 

(start-memory read physical Inet-control-address) 
(io-board-bug-delay) 
(nop) 

(if (field-bit msnory-data iXncr-data-val id) 
(noto sui tch-to-rece i vc) 
(drop-throunh) ) 
(net-control nil t) 

(paralie! (assign Inet-backof f-count (1- %net-b3ckof f-count) ) 
(it (m tnus-f ixnum obus) 
(drop-throuah) 
(goto backoff-timer))) 
;; Hers backoff has expired 
iterBinate-nct-dma Xnet-micrq-status-idle) ) 
;;; This is logically part of the device terv Ice stuff ^^ ~ 

idefucode net-service-loop 

(if (bit XXservice-receive-end) 

(paraliet (assign IXservice-receive-end (b-constant 8)) 

(jump net-receive-completion)) 
(drop-through)) 
(if (bit XXservtce-transmi t-col li sion) 

(parallel (assign XXservice-transfni t-col I ision (b-constant B)) 

(jump net-transmi t-coi i ision) ) 
(drop-throucjh)) 
(if (bit XXservtce-net) 

(dispotch-af ter-thi s net-micro-status 

_^ ,, ^ (assign XXscrvice-net (b-constant 0) ) 
V/*^^?'*.*^* all functionally cpuivatont, keep hands off dma task 
((Inet-mtcro-st3tus-transmit-u2it Xnet-micro-status-receivina 
Xnet-micro-status-transmitting Xnet-micro-statuo-ignor inq 
Xnet-micro-status-bscking-off) 
(jump devicc-serv ice-end)) 
((Xnet-micro-status-idle) 
(ooto service-net-idle)) 
((Xnet-micro-status-reset) 
(assign Xnet-backof f-count (b-constant -D) 
(assign Xnet-packet-being-received (b-constant -1)) 
(parallel (assign Xnet-packet-being-transrai tted (b-constant -1)) 
(jump reset-net-dm2))) 
( (Xnet-micro-status-receive-wai t) 
;: If ue have a packet to transmit, try to 
(if (mmus-f ixnum Xnet-tranc'.H t-Met) 
(jump device-service-end) 
;; Otheruise, reset and go to idle 
(goto reset-net-dma) ) ) 
((Xnet-micro-status-transmi t-done) 
(goto scrvice-net-transm it-done)) 

(drcp-through) ) 
(jump device-service-end)) 

(defucode reset-net-dma 
(psraiiel (start-memory write physical Xnet-control-addre*s) 

(for-effect'";^vice-ne^:con?rort)r*'"* '"'' 'Insr-error-clear '.gsconatant) ))) 
(parallel (set-net-status Xnet-micro-statua-idle) 
(jump servtce-net-idle)) ) 

(defucode service-net-idie 

(parallel (start-mcT.ory write physical Xnet-contro I -address) 

.. Ai * (assign mcmcru-data (b-constant (get 'XnEr-error-clear 'eusconstant) ) ) ) 
;; A ways prepare a packet to be received into cy^consTaniM w 

tif (minus-f ixnum Xnet-packet-being-received) 
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(paral lei 

(assign Xnet-packet-being-recetved !Cnet-free-t ist) 
(if (not (minus-f ixnua Xnet-free-l ist) ) 
(sequent ia I 

(phus-meni-read Xnet-free-I i st) 
(assign Xnet-free-I ist nemory-data)) 
(drop-tnrough) ) ) 
(drop-through) ) 
;; If ue can transmit, try to 

(if (minus-f ixnum ^ne t -packet -be i ng- tr ansm J t ted) 
(parallel 

(assign tnet-packet-being-transrot tted ICnet-transmi t-I 1 st) 
(if (minus-f ixnum Xnet-transmi t- I i st) 
(drop-through) 
(sequential 

(paral lei (phys-men-read Inc t-tranemt t-l tst) 

(assign Xnet-next-backof f (b-constant (1- (leh 1 2))))) 
{parallel (assign !Cnet-transmi t-l ist memory-data) 
(juinp start-net-transmi tter) ) ) ) ) 
(goto start-net-transmitter)) 
:; Oti-.eruise start receiver if ue can 
(if (minus-f ixnum tnet-packet-be ing-recei ved) 
(jur.p devlre-cerv ice-end) 
(drop-through)) 
(set-net-statu3"'-inet-micro-status-rer.eive-wai t) 
(assign *Xnet-block-pointer (+ 5inet-packet-being-recei ved 

(b-constant (f ield-uord-of f set •ether-packet-dest-high) ) ) ) 
(ass inn 'Znet-word-count (1- (b-constant 2))) 
Iparaile! (stsrt-memcry write physical tnet-control-ao'drees) 

lass i en. memory-data (b-constant (get 'Xnsr-receive-start *8yscon8tant) ) ) ) 
(parallel (start-net-dma net-receive-dma) 
(ju.Tip device-service-end))) 

(oefuccde start-net-transmitter 

(if (trinus-f ixr.um Xnet-b2ckof f-count) 
(:ir6p-throu?h) 
(goto start-net-backoff)) 
set-net-stotus inet-mi cro-status-tronsmi t-wai t) 
(parallel (start-memory tjrite physical Xnet-controt -address) 

(as^'inn memory-data (b-constant (get 'Insr-transmi t-start "sysconstant) ) ) ) 
(parallel (star t-net-drr.a net-transmi t-dma) 
(jump device-serv ice-end) ) ) 
:;; Sequencer special functions 

;Halt the machine after executing this nicroinstruct icn 
(defnicro hal t (reason) 

reason ; ignored 

' (Bicroinstruct ion spec halt)) 

;Pop a word off of the control stack and put it into HPC 
(defmicro popj-into-npc 

Maicroinstruction sequencer pop-npc spec npc-nagic magic 3 magic-nask 3)) 

'd*!5 !k^ '^P ?^**^!.^°r!-^JI°l ^^^^^ 2nd pop ft (aiso puts it into r!?C) 
: Read the tnput tothe NPC (taken from the control stack) onto the Lbus 




•(parallel (read-lbus-dev 3S 1) 

(■icroinstruction spec npc-magic iiagic 1 magic-mask 3 sequencer pop-npc 
speed very-slow))) r- k k 

;Urite fFC from Obus; use task-dispatch in next cycle to branch there. 
:The spec does ail the work, but we also need to do a bogus microdevice write 
;m order to make bus scheduling happen properly. mcrocevice wr t le 

;Use subdevice 7 in the F£P board (only subdevices 8-2 exist), 
(defaicro long-drspatch (data) «-«i»i/. 

(paralyze (get-to-obus32 data) 

(selectq «machine-version» 
( (sim proto) 

'(microinstruction spec npc-magic magic 2 magic-mask 3 
, .. . write- 1 bus obus Ibus-dev-addr #. (+ 3B 5 7))} 

lotherw i se "• 

Mmicroinstruction spec npc-magic magic 2 magtc-mask 3 mem microdevice 
write- 1 bus obus Ibus-dev-addr #. (+ 36.B 7)))))) 

jUses b-temp 
(defuicro read-csp 

(selectq *machine-version« 

Usim proto) (retch **Cannot read CS? on old machine")) 
(otherwise Msccuentiat 

(parallel fassinn b-temp (read- Ibus-dev 35 D) ;Read dummy device 
imfcro instruct I on spec npc-magic magic 1 magic-mask 3 

(l^^ K +.«^ A 1C ^^^^^ ®P*®^ very-slow)) 

II db b-temp 4 IB. ))) ) ) 

;Uses b-temp 



4,887,235 
221 .222 

(defmicpo read-cur-task-and-csp 
(selcctq »raach ins-version* 

((stB proto) (retch ''Cannot read CUR-TASK and CSP on old uachine")) 
(otherwise '(sequential 

(parallel (assign b-terap (read-Ibus-dev 3S 1)) jRead dummy device 
(micpo instruct ion spec npc-magic magic 1 «agic-mask 3 
speed very-slow)) 
(Idb b-temp S IS J ) ) ) ) 

;Urite into an Lbus device 

;NIL nay be specified for the data, which means «e don't care what's written 
(defaicro ur i te- Ifcus-dev (csrd subdevice, data) 
(setq data (microexpand data)) 
(paralyze (and data (get-to-obus data)) 

(microexpand * (celect-lbus-dcv ,capd ,8ubdevicc)) 
(selectq «machine-version* 

((sim proto) '(microinstruction writ«-Ibus cbus)) 
((tnc tmcSi '(microinstruction 

write- 1 bus , (cond ((null data) * junk) 

((and (eq (car data) 'microdata) 
(eg (cadr data) *abus) 

(fieldp (caddr data) 'abus 'memory-data)) 
•memory-data) 
(t 'cbus)) 
mem microdevice) ) 
(o.therwtse '(microinstruction write- lbus cbus mem microdevice) ) ) ) ) 

;Read from an Lbus device 
(defciicro read-Ibus-dev (card subdevice) 
(make-mi crodata 'afcus 

(paralyze (microexpand ' (select-lbus-dev .card .subdevice)) 
(selectq «machine-version« 

((sim proto) • (microinstruct ion abus lbus)) 

(otherwise '(microinstruction abus lbus men microdevics 

speed slow-second-haif)))))) 
;slow-second-hal f is because the 10 tiD latch on the TfIC 
•does not open until second half, and then the data still 
;have to propagate to the DP board and through 8334. 
;Keed this to avoid GC map parity error, 

(defmicro se lect- Ibus-dsv (card subdevice) 
(or (and (fixp card) (<• Q card 37)) 

(and (sytr.oolp card) (get card 'symbol ic- Ibus-slot) ) 

(retch "«rS illegal slot number" card)) 
(or (and (fixp subdevice) (<- 9 subdevice 37)) 

(retch "^.S ilieaat subdevice nur.cer' subdevice)) 
'(microinstruction Tbus-dev-addr .(if (symbolp card) 

.•(,card .subdevice) 

(dpb card 8505 subdsvice) ) ) ) 

(def&acro define- I bus-card (name) 
•(evai-when (compile load cval) 

(cefprop .name t symbol ic- I bus-slot) ) ) 

;Urit3 the control register on the data path 
(defmicro wr i te-dp-contro 1 (source) 
(paralyze (get-to-cbusSZ source) 

'(microinstruction spec load-control))) 

(defatomicro Ibus-dev-cond 

'*'''^f"jpfO"^!l*_o" not- Ibus-dev-cond false nil)) 
;;; Tasking 

(defmicro read-cur-task 
(selectq «machine-version« 

((Sim proto) (retch "Cannot read CUR-TASIC on old mschine")) 
(otherwise ' (sequential 

(parallel (assirtn b-teirp (read-Ibus-dev 35 D) ;Re3d dummy device 
imtcromstruction spec npc-magic magic 1 magic-r.ask 3 
speed very-slow)) 
(Idb b-temp 4 2C.))))) ^ 

(defmicro wakeup-task (n) 

(setq n (decode- task-number n) ) 
'(microinstruction spec awaken-task magic-mask 3 

magic .(or (f ind-posi t ion-in-1 ist n Ml 2 5 B)) 

(retch "^S illegal task number here" n)))) 

(defmicro wr i te-task-state (n value) 
(setq n (decode-task-number n)) 
(paralyze (get-to-obus32 value) 

'(microinstruction spec write-task 

mem microdevice wri te- 1 bus obus Ibus-dev-addr tf.U 3S 5 7) 
force-obus<33-22> ,(ldb eC32 n) - 

force-obus<35-34> .(Idb 8232 n) ) ) ) 

(defun decode-task-number (n) 

(o?'^(lnd''uiSp"n)^Tre"n'l7n°'''^^"^^ ^^^"^ " ^^®* " 'cysconstant) ) ) 
(retch ***.§ illegal task numoer here* n) ) 



n) 
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(defmtcro dlsmics 

' (nicroinstruct ion cequencer dismiss)) 

;nuEt be used twice in a row to work 
(defmicro di sab I e-task i ng 

' (microinstruct icn spec di sabie-tasking) ) 

:cdr -code- insert ion hardware 
{declare (special «:cdr-codes») ) ;in Slfl 
(defmicro «et-cdr <val cdr) 
(let (icdr*code 

(if (numberp cdr) cdr (f ind-posi tion-in-l ist cdr »cdr-code5») ) ) ) 
(or cdr-code (retch "^S undefined cdr code" cdr)) 
(make-nicrodata 'obus 

•(parallel , (get-to-obus val) 

(microinstruction force-obu8<3S-34> »cdr-code) ) ) ) ) 

jdata-type-insert ion hardware 

(declare Ispecial *data-types*)) ;tnSin 

(defnicro set-type (val dtp) 

(let ((dtp-code (if (numberp dtp) dtp (f Ind-posi tion-in-l ist dtp »:data-tupes«) ) ) ) 
(or dtp-code (retch "^^S undefined data type" dtp)) 
(eake-oicrodata 'obus 

•(parallel , (get-to-obusSZ val) 

(microinstruction f orce-obus<33-32> »(lsh dto-code -4)) 
,(if (not (memq dtp '(dtp-fix dtp-flcat))) 
(let ((num (logand 17 dtp-code))) 

Maicroinstruction force-obus<31-28> ,nu» 
«agic , num) )))))} 

;Set-cdr from a 'variable* rather than a 'constant* 

; — This and the next could be changed to allow background on BBus also 
(defffltcro merge-cdr (typed-po inter cdr-bcckground) 
(Bake-»icroa3ta "obus 

(paralyze (get-to-obus typed-pointer) 
(aet-to-abus cdr-background) 
Mwicro instruct ion force-obus<35-3A> abus)))) 

;Take low 32 bits from one source and high 4 from another 
(defaicro merge-niah-tag (typed-pointer tsg-bacKground) 
(make-aicrodati obus 

(paralyze (get-to-obuE32 typed-pointer) 

(get-to-abus tag-background) 

* (microinstruct ion fcrce-obus<35-34> abus 

force-obus<33-32> abus)))) 

Storing into memory 

The type map for normal storing, which simply identifies whether or 

net a pointer is being stored. This is what enables the oc tag hardware. 

declare (special «3tor mg-type-map*) ) ;inULIX 

Store the contents of the currently-addressed memory location, with 

gc tag en-sbled, and with the cdr code coming from either a constant 

or the cdr field of another- source or the some source (if unspecified). 

This IS different from ass:aning to menory-data, because the 

latter is a lower-level operation which does not turn on the gc tagging. 

Note that the cata to be stored is normally assumed to be a typed pointer and 

hence «ust come from the Abus so that it gets to the data tune 

logic. ** 

The following ootions may be specified: 

aPr;:^*^^^^^^? " ^^'iif 's ^noun not to be a pointer, may come fronj Ebus 
BLClIC - Increment VflA after storing 
car-code-name - set cdr-code to that 

riEnc fc^rnnn ac 7-^°c* ^dr ccoe from source (number, cdr-code name, cr datum) 
UbLb-AS-bUCD-AS-ADuS - this kludge says that gc-map looking at abus data 
^^ -„-„ instead of obus data wilt not hurt anything 

H»4«;r.^rr;+«S2 ^^ * * - this kludge saus that ue won't be writing a aapped-into-amem address 
defmicro store-contents (typed-pointer Srest options 

&aux (cdr nil) (cdr-inst nil) (not-pointer nil) (block nil) 
o ,. (oDus-ao-good-as-abus nil) (amem t)) 

:; Parse opt ions 
(del ist (opt options) 

(ccnd ((eq opt 'not-pointer) (setq not-pointer t) ) 
((eq opt 'block) (setq biock t) ) 

((eq opt ]obus-as-gccd-as-abu£) (setq obus-as-good-as-abus t)) 
((eq opt 'no-smem) (setq amem nil)) 
((memq opt *cdr-ccdes*) 

(setq c:ir (f ind-posi t ion-in- I ist oot »cdr-codes«) ) ) 
((and (listp opt) (eq (car opt) 'cdr)) 

;; Decompose into cdr, the obus cdr-field forcing, and cdr-inst, other code. 
(setq ccr (cadr cpt)) 
(cond ((numberp cdr)) 

( (menq cdr *crir-codeE¥) 

(s5tq cdr ^ (f ind-posi t ion- in- I ist cdr *cdr-codes*) ) ) 
; (eq cdr 'memory-data)) jthis misf&al'jre has been flushed from the hardware 
((and not (ntom (setq cdr-inst (microexpsnd cdr)))) 
(cq (car cdr-inst) *microdata) 

(mcmq (cadr cdr-inst) '(abus bbus) ) ) :abus-onhj on the proto... 
(setq cdr (cadr cdr-inst) 

cdr-inst (caddr cdr-inst))) 
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(t (retch "-vS not a data source that can feed cdr field" cdr) 
tsetq cdr nil cdr-inst nil)))) 
(t (retch "'*5 not a valid option" opt)))) 
{paralyze (cond (not-pointer 

(cet-to-obus tuped-pointcr) ) 
(oErus-as-good-3fc-abu3 
(para ly?? 

(gct-to-ot3u3 typed-po inter) _ 

•{plicroinstruction type-map ,«stortng-type-map*) ) ) 

(t 

(paralyze 

(get-to-Cbu8 tuped-po inter) 

M»»cro instruct ion type-«sp ,»« toning- type-map* 
X&U9 apus 
alu xbus)})) 
(and cdr * (microinstpuct icn force-obus<35-34> ,cdr)) 

(and amcra • (niicroinatpuction amem-wri te-addr (bus-address))) 
(aelectq »fnachine-veP8ion* 

((sim ppoto) . . ^ . . X _,f.i \ 

(if block {petch "store-contents block option not implemented )) 
* (mi cpo instruct ion up tte- 1 bus obus 

Ibus-dev-addr uptte-memory 
tpap-enables (map-miss) 
mem start-cycte) ) 
(othcpwice 
(micpoexpand (if (not block) 

Mstapt-meicory write) ^ 

* (star t-memopy wr i te b 1 ock) )))))) 

;ALU opepations 

;You get IG functions of each kind 

; Things depend on X3US and ALUS not being weird 

(def const norma I -a iu-f unctions 

Mxbus aiub X+1 X-1 X+Y X-Y X+Y+1 X-Y-1 and iop xor)) ;5 spares 

(def const ue i rd-a I u- functions 

• (X+1-overf lew X-1-overflow X+Y-overflou X-Y-overflcu 
X-Y-signed X-Y-1-signed nand andcy)) ;S spares 

(defun alu-microinctruct ion (func) 

(cond ((memq func nornal-alu-funct ions) 

'(microinstruction alu ,func)) 
((memq func weird-alu-funct ions) 

•(microinstruction alu .func spec ar I thme tic- trap-cnb magic 4)) 
(t (retch "*S undefined ALLi function" func)))) 

; Define 1 -operand ALU function 
;Hair so that ubus operands work, too. 

(def macro defaluopl (name field ycode ^optional other -code) 
Mdefmicrc .name (x-opnd) 

(setq x-opnd (mi croexpsnb x-opnd) ) 

(paralyze (if (memq Icaar x-opnd) ' (ybus alub)) 

(microexpand (subst x-opnd 'y \ ycode)) 
(make-mi crodata 'obus 

(aiu-paralyze (get-to-xbus x-opnd) 

(alu-microinstruction \field)))) 
'.other-code))) 

;Define 2-operand ALU function (optional third operand is constant 1) 
;If one-operand? is specified it is code for the one-operand case 
; otherwise require 2 or 3 operands, 
(defoacro defaiuop2 (name fieid 

fioptionat commutative? third-operand? one-operand? 
other-code) 
•(dDfmicro .name (x-opnd 

,«(if one-operand? * (Aopt ional ) ) 

y-opnd 

,«{if third-operand? 

(if (not one-operand?) 
* (dopt ional one) 
'(one)})) 
, (i f third-operand? 

' (or (nu 1 I one) (equa I one 1 ) 

(retch "^Third operand to --S must be 1, not -S" \name one))) 
, ( let ( (two-cp-code 

' (make-microdata 'obus 

(alu-paraiyze .©(i f commutative? 

• ( (get-to-xbus-and-alub x-opnd y-opnd)) 
'((get-to-xbus x-opnd) (get-to-alub y-opnd))) 
(a I u-micro instruct ion 
,(if (not third-operand?) ".field 
,. , '(if one '.third-operand? \f ield) ) )) ) ) ) 

( r t (nul 1 Other-code) 

(if (not one-operand?) two-op-code 
•(if u-cpnd . tuo-op-code 

(subst x-opnd 'arg ' .one-operand?) ) ) 
"(parallel ..(if (not one-operand?) two-op-code 
•(if u-opnd , two-op-code 

(subst x-opnd 'arg '.one-operand?))) 



(defaiucp? 
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,\other-code)/)i J 

(defaluopl 1+ X+1 (xbus-constant-hack X+Y 1 y)) 

(defaiucpl 1- X-1 (xbus-constant-hack X+Y -1 u) ) 

(defalucp: + X+Y t X + Y-^l) 

(defaluop? - X-Y nil X-Y-l ixbus-constant-hack X-Y 8 arg) ) 

(def2!uor.2 conrnutat i ve-di f f X-Y t X-Y-1) 

(aefaluc-rT lc-:;anci and t) 

(cefaiuoD? iccnand nand t) 

(detaiuop2 leg tor icr t) 

(defaiucj:!-' icnxcr xor t) 

(aefalucp2 anJc2 andcy nil) 

(defaiucpl inc-checkinr]-overf low X+1 -over flow 

Ubus-constant-hack X+Y-overflou 1 y) 

(ffiicpoinstruct ion trap-ensDtes (overflow))) 
(defaluopl d3c-checK ir g-overf lou X-1-overfiow 

(xbuD-ccnstant-hack X+Y-overflow -1 y) 

(microinstruction trap-enables (ovcrfiou))} 

a:ld-check ing-overf low X+Y-overflow t nil nt ! 

(microinstruction trap-enables (overflow))) 
(defaiucp2 sub-check ing-cverf low X-Y-ovcrflow nil nil nil 

(microinstruction trap-enables (overflow))) 

;Used internal I ij: ALU can also feed through xbus or alub 

;Thts piece of hoir generates an ALU operation with a constant on 
;the xC'jG and nn arq-jr^ent en the alub. The hair is to decide which 
tmenc^'j to put ^he constant in. 

(Oefm.cro xLus-ccnctant-hack (alu-op constant y-opnd) 
(setq u-opnd (get-to-alub y-opnd)) 
(oake-microdata 'obus 
(alu-paralyre y-opnd 

Tget-to-xbus (if (uscs-fcbus y-opnd) '(a-constant .constant) 

•(O-ccnstant .conatcnt))) 
Mmicroinstpuctton alu ,alu-op)))) 

(defun uecs-bbus (instruction) 

(cond ( ieq (car instruct ion) 'microsequsncc) 
(uses-bbus (car (last instruction)))) 
( (eq (car instruction) *Biicro instruct ion) 
(loop for (field value) on (cdr instruction) 
thereis (eq field 'bbus))) 
((eq (car instruct ion) *ciicrcci3t3) 

(uses-bbus icadar instruction! } ) 
(t (retch *'uses-bbuc: Uhat da tuck fs dis? — ^S" instruction)))) 



tdefun alu-paralyzel (inst) 

(seiectq (car tnst) -^ 

( (microinstruct Ion) 
(and (ffieinq (get inst 'alu) MX+Y X^Y X+Y+1 X-Y-1 X+Y-overflow X-Y-overftow 
, , , , ^ . ^ , X-Y-cigned X-Y-l-signed)) 
(seiectq (get mst 'ybus) 

(abus (seiectq (net inst 'abus) 

((arr^em) I let ((a (get inst 'arnem-pead-addr) ) ) 
,, Jor (atom a) (neq (car a) 'constant)))) 
UmetRory-data memory-data-force Ibus nap) t) 
i^^ / ^ot^^eruise nil))) ;bases, vma, pc are fast 

(bbus (seiectq (aet inst 'bbus) » h^ «r c 

((btnem) Tiet ((a (get inst 'bmem-read-addr) ) ) 
* *t. ^^^ Jf^?^ ^* ^"^'^ ^car a) 'constant)))) 
I * (otherwise ni I)))) ;n:2CP0-ii!mediate* s are fast 
inst) ^ (paralyze mat ' (microinstruct ion speed slow-second-hal f) )) ) 

( (mi rrosequence) 

(cons ;»icrosequence (tiiapcar jy'alu-paraluzel (cdr inst)))) 
(otherwise (retch "^S not a ffiicroinstructlon" inst)))) 
;;; Support for byte fields ' 

(defmacro byte-mask (ppss) 
(apb -1 

(cond ( (nuniberp ppss)) 

((not (get ppss 'byte-field)) 
(retch "^S not a defined bute field" ppss)) 
^ ((car (get ppss 'byta-f ieldJ))) 

(defun byte-pp (ppss) 
(Ish ppss -b)) 

(defun byte-ss (poss) 
(logand 77 ppss)) 
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(defun byte-pp-ref iecteri (ppas) 
(iogand 37 (- 48 Ibute-pp ppss)))) 

idefun bute-numpers-to-ppss (n-bits bits-over) 
(+ (Isn bits-over 6) n-bita)) 

(def macro defatomic-byts- field (name bLjte-speci f ier register) 

ilet (UbacRtrace* (cons * ((defatctaic-byte-f ield ,naae)) «backtpace*) ) 
(ppss (if (Mstp byte-specifier) 

(bytc-numbeP8-to-ppss (first byte-specifier) (second bute-spcci f ier) ) 
(car (get byte-specifier 'byte-field))))) 
(or ppss iferror nil ■*S not defined as a system byte" byte-specifier)) 
Meval-uhen (con:pile load evat) 

(defprop ,name (,ppss , register) byte-field) 
(defatomicro ^name 
, (make-nicrodata 'aiub 

(paralyze (oet-to-ybus register) 
* i»icrotnstruct ion 

byte-func (Idb , (byte-pp-ref Iccted poss) 
,(byte-69 ppss) )))))})> 

(defiracro def-byte-f le! d (name byte-specifier place) 

(let ((*.back trace* (cons M (def-byte- f ield »name)) ^backtrace*)) 
(ppss (if (I istp byte-speci f ier) 

(byte-nuirbcrs-to-ppcs (first byte-specifier) (second byte-specifier)) 
(car (get byte-specifier 'byte-f ioid))) J ) 
(or ppss (ferror nil "^S not defined as a system byte" byte-specifier)) 
Meval-when (cocipile foadeval) 

(defprop ,name (,ppss) byte-fieidl 
(defmtcro ,naffle (.place) 
InaKe-microdata ^alub 

(paralyze (aet-to-ybus , place) 
• Imicroinstruct ion 

byte-func (Idb , ' , (byte-pp-ref lected ppss) 
,\(byte-ss ppss))))))))) 

;Use this to define the a-list of sgntbolic dispatch cues associated uith a field 
(defracro acsociate-di spatch-cues (field-name enumerated-type-name) 
Meval-uhen (compile load eval) 

(defprop .field-name .enuaerated-type-name enumerated-type-nanie) ) ) 

;U*ie this to define them as atomicros that are B-constants 
(defracro def ine-enumerated-value-constants (enumerated- type-name) 
(let ((codes (get enumerated-type-name *enumerated-type-codfts) ) ) 
( i f (nul t codes) 

(ferror nil "-^.S not declared as an enumerated type" •numerated-type-name)) 
(progn 'compi te 
. ,(lccp for (code . value) in codes 
collect '(defatomicro ,code 

(b-constant .value) )))) ) 

:Siriilar, for uor6 offsets in a defstora^e 

(defnacro def ine-storage-word-of f set-ccnitants (def storage-tuoe-narae) 
(let ((fields (get defstorage-type-nar;5 'defstorage-f ields) ) ) 
(if (nul I fields) 

(ferror nil "-S not declared as a defstorage type" defstorage-type-name) ) 
• (progn *coppi le 

. ,(loop for field in fields 

collect • (defatomicro .field 

(b-constanl , (f ield-word-of feet field))))))) 

;5tn(iar for a single constant defined uith defsysconstant 
(defmacro def i ne-sy-constant (name) 

(or (get name * stjsconstant) (ferror nil VS not declared with defsysconstant")) 
idefatomicro .norne 

(c-constant .(get nan^s *8yEConstant) ))) 

;;; nicros for more direct access to tho shi ft/mask/merge logic 
(asfr^icro rotate (opnd left-amt) 
(r.ake-r. icrcdata 'alub 

(paralyze (net-to-ybus opnd) 

^microinstruction byte-func (Idb . lef t-amt 32.))))) 

(riefmicro Irtb (cnnd n-bits bits-over dcrtional backaround) 
(ff (equal background 8) (setq background nil)) 



(va I i date-byte-spec i f ier n-bits bits-over) 
(maKe-microdata ali 



a a tub 
(paralyze (gct-to-ybus opnd) 
Mmicroinstruct ion 

byte-func (Idb .(selectq bits-over 

((byte-r «acro) bits-over) 
(otherwise (Iogand 37 (- A8 bits-over)))) 
,n-bi ts 
, f«(if background Mmercre)))) 
(if background (get-to-xous background))})) 

(defmicro dpb (opnd n-bits bits-over background) 

(if (equal background 8) (setq backaround nil)) 

(vai idate-byte-crrci f ier n-bits bits-over) 
(make-mtcrodata ^afutD 
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(paralyze (cet-to-yfcLis opncJ) 

'Imicroinstruction byte-func (dpb .bits-over ,n-bit3 

,.. ^ ^ ^ , . . ••^'^ background •(merge)))) 

(if background (get-to-xbus background))))) 

jAlternate version of LDB used by certain hacks (subpr imi t ives) 
tAllows you to take advantage of the fsct that bytes split across the 
:eno of the wcrd utprk i.e. it reaMu is a rotate followed by a mask), 
(defffiicro strange-Ida (cpnd n-bits brts-over Soptional backcround) 
(if (equal background 8) (setq background niln 
(make-mi crodata 'alub 

(paralyze (get-to-ybus opnd) 
' In i cr i ns true t i on 

byte-func (Idb ,(iocjand 37 (- 40 bits-over)) 
,n-bits 
,. ,e(if background MmerQe)})) 

(if background Cget-to-xbus background))!)) 

'/![I*'^'"'^ !*?^I the cpecified byte lies within the low 32 bits and is otheruise legal, 
(defun val tdate-byle-spec) f ter (n-bi ts bi ts-over) 
(or (sunibolp n-bi ts) 
(< 1 n-bits 32.) 

(retch -The number of bits, *S, is not between 1 and 32." n-bits)) 
(or (symbotp bits-over) 
(< 8 bits-over 31.) 

(retch "The bit position, *.S, is not between 8 and 31." bits-over)) 
lor (syr--oIp n-bi ts) (sunbolp bits-over) is (+ n-bits bits-over) 3?.) 

(retch The byte specified at ^S *S overlaps the 32-bit word bcundaru" 
n-btts bits-overj)} ^ 

: invoke special hair in the SKFriSKB PAL 
(def micro con:plerr.ented-sign-bi t (opnd) 
Mparai lei (loo ,opnd 1 31.) 

(microinstruction spec alub-sign-hack) ) ) 

jCet a byte by name rather than bu bi ts,bi ts-over. 
(deffr.icro Idb-field (operand field-name fiopt ional (background 0) ) 
(multiple-vatue-bind (n-bi ts bi ts-over) 

(ceccae-byte-f ield-specif ier f ietd-name) 
(Idb , operand , n-bits ,bi ts-over , background) ) ) 

(defmicro dpb-field (operand field-name background) 
(mul t iple-vaiue-bind (n-bits bits-over) 
^ (decode-by te-f i e I d-spec i f i er f i e I d-name) 
(dpb .operand , n-bits .bits-over .background))) 

(defmacro tdb-field (operand field-name) 

tict ((ppss (car (get field-name •byte-field)))) 

wThS'^^! (ferror "-S is not a defined byte field" field-name)) 
(Ido ,ppss .operand)}) 

(deff;.acro d;:b-f!eld (operand fieid-name background) 
net ((ppss (car (net field-name •byte-field)))) 

(cr ppss (ferror "-S is not a defined byte field" f ietd-name)) 
(opb .operand ,ppss .background))) 

(defriacro field-mask (field-name) 

(let ((ppss (car (get field-name 'bi^te-f ield) ) ) ) 

(dpb^-rppsrG?)}""^ '^ ''°^ ^ defined byte field" field-name)) 

(defmicro field-bit (operand field-nar-) 
imul t iple-value-bind (n-bits bits-cver) 

(cccode-bute-f ield-cpccif ier field-name) 

maki*m?;rnro.i'f-'"^^?^/:^ci'? "°^ ^ single-bit firld" field-name)) 
imaKe-m tcrocond 1 1 ton a!ub-0 true 

(paralyze '(microinstruction 

byte-func (Idb .(loqand 37 (- 40 bits-over)) ,n-bitn)) 

(get-to-ybus operand))))) 

(defun decode-byte-fietd-Epecifier (field-name) 
net ((pp3£ (ca-- (jet fiefd-name 'byte-field)))) 

or PPS3 retch ^5 is not a defined byte field" fiold-name)) 
lvalues 1 1 C'^jar.d 77 ppsc) 
(Ich ppss -ci))) 

;;; Since the proto machine is dead, don't bother checking, 
(defatomicro byte-s 

(Idb ybus-crocks-2 5 24.)) 

(defatomicro byte-r 

(IdD ybus-crocks-1 5 24.)) 
;; ; tlul t ipl icat ion 

:Readtng out the 32-b(t signed product of X and Y registers 
(defato»icro mpy-product =* a^trcs 

(cucrcdata xdus 

(microinstruction xbus product 
spec tr.ul t ipfy 

cagic -» 

speed viM-y-slow))} 
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;nultiplier input registers here nr-^ed after the burses they are 
;on» rather than the'TRU nar..33 i-'hich ere reversed. 
; Loading the multiplier is not rione uith ASSIGm, rralnlu berausa 
;of the weirdness that it loads frcn the -high- half or Ybus. 

;Uriting into the X register, sinned cr unsigned 
(def»icro uritc-mpy-x (x-source ^optional signed) 
iparalyze (get-to->:bus x-sourceJ 

* Inii croinstruct ion spec multiply 

magic ,{if signed S 2)))) 

;LIriting into the Y register, stoned cr unsigned 
(defBicro ur i te-mpu-y-from-high "(u-source fiopticnal sirj"»ed) 
tparatyre (aet-to-ybus y-source^ 

Mmicrotnstruct ion spec cultiplu 

magic , (if signed 11 1)))) 
;;; Main aemory " 

{defatomicro memory-data 

(microdata abus (microinstruction abus memory-data amem-rcad-addr (bus-address)))) 

;The virtual-address register 
(defatcnicro vma 
tvrr.a-kludge) ) 

;For temporary memory control, cannot read back hardware VMA. so keep copy in A-mcmory 
(dcfnreg-at-toc a-vma-copy 2S&1) jLocation kfudQi iy known about.., 

(defmicro vma-kludge i) 

(if ieq ^machine-version* 'proto) 
•a-vma-copy 
•(microdata abus (microinstruction abus vma)))) 

:Also there is hair in ASSIGN 

: Start a me?r.ory cycle 
;Do this the cycle after loading vma 

;The modes argument says what kind of cycle. It is not used on the proto machine; 
;the kind of cycle is determined by what you do in parallel with this. 
;See the microccmpi ler documentation for the modes, 
(defmicro start-memory (firest modes) 
(selectq *machine-vers i on* 

Msim proto) '(microinstruction trap-enables (map-miss) mem start-cycle)) 
((tmc tmcs) 
(let ( (direction ni I) 

(physical -address nil) 
(spec nil) 
(dma-device nil) 
(block nil) 
(i fetch ni I) 
(inst ni I)) 
(loop until (null modes) 

as mode • (pop modes) 
do (selectq nocfe 
((read write) 
(i f (nul I direction) 

(setq direction mode) 

(if spec (retc:. "Conflicting spec funcsr -^S and -^S" 

spec *ch2Ck-wri te-accBSs) ) 
(setq direction 'read epec 'check-wr i te-access) ) ) 
(physical 
(if inuU modes) (retch "No physical address specified")) 
(setq physical -address (pop modes))) 
(dma 
(if (null (cclr modes)) (retch "No OflA card/Zsubdevice specified")) 
(if spec (retch "Conflicting spec funcs: -S and ^S** epec ciode)) 
(setq dma-device (list (pop modes) (pop modes)) 
spec 'draa)) 
( (inhibi t-pags-taos address-phtc) 
(if spec (retch ^Conflicting spec funcs: *.S and -^S" epec mode)) 
(setq spec mode) ) 
(bicck 

(setq block t)) 
(instruction-fetch 

(setq (fetch t)) 
(otherwise (retch "*rS unrecognized START-nEflGRY mode" mode)))) 
(or direction (retch "Neither READ nor QRITE specified in START-flEflORY'*) ) 
(cond ((not phus ica I -address) ) 

((null spec) (setq spec 'addr-from-abus) ) 
((not (men^q spec * (dma inhibi t-page-tags)) ) 
(retch "Conflicting spec funcs: ^S and *S" spec 'addr-from-abus) ) ) 
(and block spec 

(retch 'Cor.binat/on of block mode and special memory features is illegarU 
(setq insit (list 'mem (if (not block) 

(if (eq direction 'read) 'start-read 'start-write) 
, ^ ,., (if (eq direction 'read) 'block-read 'block-write)))) 

(ccnd ((fetch 

(if spec (retch "Conflicting cpcc funcs: *S and ^-S" spec ' i fu-controi ) ) 
(setq inst 



(cpec 
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(if (eq »niachine- vers ion* 'tmc) 

(list* 'spec *ifu-control 'wagic 9 •magic-mask 1 inst) 
(iist* 'spec 'ifu-control 'cagic 2 'nagic-mask 3 inst)))) 



tsetq inst (list* 'spec spec inst)))) 
inst (: ' " ■ 



(cetq inst (cons 'microinstruction inst)) 
Iff drna-dGvice 

(setq inst * (parallel (se lect-lbus-dev , (car dma-device) , (cadp dma-devtce)) 
, inst))) 
( I f phtjoi ca I -address 

Used extra tir:e uhen taking addr from amen, and cannot use addr-calc 
harciuare, in order to get enough address-to-clock setup time 
1 if;T ( taddr (rist-to-apus phijs i ca I -address) )) 
(or (atcn (crct addr ' amcm-read-aJdr) ) 

(eq (c:ir (gst addr * anen-read-addr) ) 'constant) 
(retch "^S is too slow as a source of physical address" 
physical-addrecs) ) 
(setq inst Mparaiiel ,a ddr 

, inst 

(microinstruction creed alou-f irst-hal f ) ) ) ) 
;: Need extra time when' using the map cache bccausa it isn't fast enough 
(setq inst '(parallel .inst 

(njcroinstruct ion speed slou-f trst-hal f ) 1) ) 
inst)) 
(otherwise (retch "Don't know how to do STAnT-MEMGRY on this machine.-)))) 

(def»icro nop 

• itticroinstruct ion) ) 

;Use this at a su^^outine uhirh is jump»d to with the rcnory going. 
;to defeat bogus error mc^sscries uhen uou know what you're doing. 
•Note: this doesn't distinguish between 10 and emulator tasks, 
(defoicro dec lare-nemoru-tTming (&re3t states) 
(doi ist (state statesi 

(or (ocmq (if (and (listp state) (eq (car state) 'next) (• (length state) 2)) 
(csdr state) state) 
' (active-c-.-: ie data-cycleU 
(retch --S i llegal'memory timina state: use ACTIVE-CYCLE or DATA-CYCLE" state))) 
"(■tcroinstruct ion deciare-memory-tTni»ng , states)) 

(def»icro dec 1 are-speed (speed) 

(or (aemq speed '(slow stou-f irst-hal f slou-second-hal f very-slow)) 
(retch ^5 not a legal speed name" speed)) 

• (■icroinstruct ion speed .speed)) 

Allowed transport types are: 

Data atl Invisibles, error if null or header 

URITE all invisibles, no transport, error if header 

CDR cnly header /body forward invisible, no tr^insport, error if header 

BIND evcc not invisible, errcr if header 

Bl'^-'D-URITE evcp not invisible^ no transport, error if header 

HEADER header-forward invisible, transport, other tuoes error 

HEADER-OR-DATA same as HEADER but no error if non-header' type 

does not actually transport any nornal-data word it sees 
NO-TRAP ? - the A machine uses this in one place, I don't think we need it 
SCAV no invisible pointers, no errors, transport 

For transport, the tune map is: 

Regular pointer »> CQND (enables oldspace check) 

Invisible-pointer -> COr^, TRAP-2 (oldspace overrides invisible) 

Bad type -> TRAP-3 (e.g. unbound-variable error) 

(def micro transport (fioptional (transport-type 'data)) 

(or (memq transport-tupe '(data write cdr bind bind-write header header-op-data scav) ) 

(retch ^S illegal transport-tupe" transport-type)} 
(paralyze (oet-to-abus 'memory-data) 

'iaicroinstpuction type-map , (type-map-for-transpopt transpopt-type) 
tpap-enables (transport) 
error-table (bad-data- type) )) ) 

(defconst transporter-type-map-at i st nil) 

;Note that this function has to be mcdtfied if «data-types» is changed! 

; dtp-monitor-forward not put in yet 

(defun type-map-for-transport (transport-type 

^Q &aux ^Q (defaui t-cons-afea uopking-stopage-apoa)) ;Stgh,.., 
(op (cdr (assq transport-type transpoptcp-type-ffiap-al i st) ) 
( I et ( ( invi si bie-po inter -types 
(selectq transport-type 

((data write) ' (dtp-externat-value-cef I -pointer dtp-one-q-forward 

dtp-header-f opuapd dtp-body-f opwapd) ) 
((bind bind-wpite) ' (dtp-one-q-fopward dtp-headep-fopwapd dtp-body-forward) ) 
((cdr) • (dtp-header-forward dtp-body-forward)) 
{(header hesder-or-data) '(dtp-header-forward)) 
((scav) ni I))) 
(error-types 

(selectq transport-type 
[(data) • (dtp-nul 1 dtp-11 



((data) '(dtp-null dtp-11 dtp-13 dtp-14 dtp-15 dtp-lS dtp-17 
dtp-header-p dtp-header-i dtp-ncni tor-forward 
dtp-72 dtp-73 dtp-74 dtp-75 dtp-76 dtp-77)) 
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iicdr) '(dtp-ll dtp-13 dto-lA dtp-15 dtp-lG dtp-17 

dtp-header-D dtD-hsader-i dtp-men i top-fopward 
dtp-72 dtp-73 dtp-?/* dtp-75 dtp-76 dtp-77)) 
((upite bind bind-write) 
Mdtp-header-p dtp-headep-i dtp-11 dtp-13 dtp-14 dtp-15 dtp-16 dtp-17 

dtp-Rcni top-fopuapd dtp-72 dtp-73 dtp-74 dtp-75 dtp-7S dtp-77)) 
((headep) (types-other-than Mdtp-headep-fopwapd dtp-hcadcp-p dtn-headep-i ) ) ) 
((headep-op-data scav) * (dtp-11 dtp-13 dtp-14 dtp-lb dtp-IB dtp-17 

dtp-72 dtp-73 dtp-74 dtp-75 dtp-76 dtp-77)))) 
(regu t sp-po i ntep-tijpe» 
(ie Icctq tpanspopt-type 

(iupite bind-write cdp header headep-or-data) nil) 
((data) '(dtp-nit dtp-syrriol dtp-ex tended-numbep dtp-locative 
dtp-list dtp-compi led-funct ion dtp-apray dtp-closupe 
dtp-instance dtp-evcn-pc dtp-odd-pc)) 
((bind) Mdtp-nuit dtp-nit dtp-symbol dtp-extended-number dtp- locative 
dtp-extepna I -va I ue-ce I T-po i ntep 

dtp-list dtp-cofrpi led-funct ion dtp-array dtp-closure 
dtp- instance dtp-even-pc dtp-odd-pc)) 
((scav) '(dtp-null dtp-nil dtp-sumbol dtp-cxtendcd-number dtp-locative 

dtp-external-value-cei T-pointep dtp-one-q-fopuapd dtp-headcp-forwapd 
dtp-list dtp-corioi led-funct ion dtp-array dtp-closure 
dtp-instance dtp-header-p 
dtp-even-pc dtp-odd-pc))))) 
(iet ((map (nccnc (and invi sible-potnter-tupes 

M(, invisible-pointer-tupes pointer trap-2)}) 
(and regu I ar-po inter-types 

'((.rerjutap-polntep-typas pointer))) 
(and error-types 

•((.error-types trap-8)))))) 
(push (cons transport-type map) transporter-type-nap-al ist) 
map)))) 
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;;; Jumping all over the place 

;Note that the condition field is also relevant to next-microinstruction 
;8eiccticn. The skip- true-sequence end skir-false-sequence fields get boiled 
;doun to the next-microaddress field, with placing of n^icroinstruct ions at 
{Suitable addresses and duplication of microinstructions in some cases. 

;Note that IF and DISPATCH may be used at the same time, and in this case the 
;IF*s skip modifies the KPC rather than the next-microaddress field. The 
;«icro3ssenibler has to be sware of this and put instructions in the appropriate 
;place5. 

(defnicro call (ucode) 

•(microinstruction sequencer pushj jump-sequence ,ucodG}) 

(def micro jump (ucode) 

'(microinstruction next-sequence , ucode)) 

(defmicro return 

'(microinstruction sequencer popj)) 

(defmicro return-skip (pred) 

(let* ((test (microexpand pred)) 

(•kip (cond ( (neq icsir test) 'microcondi tion) 

(retch "^S expanded into •^S, not a valid ■icrocondi t ion** 
pred test)) 
((memq (carir test) valid-skip-conditions) (cadr test)) 
(t (retch "^S invalid skip condition in ^-S" 
(cadr test) pred))))) 
(or (eq (caddr test) *true) 

(retch "^S is a rever sed-sense skip condition, i I legal in RETURN-SKIP" pred)) 
(paralyze (cadddr test) 

•(microinstruction condition »skip sequencer popj return-skip t)))) 

;Thts makes the return address of a call be the pending dispatch. 

;Thi8 is just for the simulator. The red harduare can't avoid doing this. 

(defmicro cal 1-and-dispatch-upon-return (ucode) 

•(microinstruction sequencer pushj-return-dispatch jump-sequence , ucode)) 

(defmicro cal l-and-return-to (ucode return-to) 

•(microinstruction sequencer pushj jump-sequence , ucode next-sequence , return- to)) 

(defmicro cal t-and-rcturn-sklp (ucode norma I -return skip-return) 
•(microinstruction sequencer pushj jump-sequence ♦ucode 

return- true-sequence , skip-return return-false-sequence , norma I -return) ) 

;Catl in combination uith a skip 

(defmicro cal I -select (condition true-rubrout ine false-subroutine) 
•Iparallel (microinstruction sequencer pushj) 
(if , condition 

,(if (atom true-subroutine) '(goto , true-subroutine) true-subroutine) 

,(if (atom false-subroutine) '(goto .false-subroutine) false-subroutine)))) 
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jCcrbination of that and cal l-and-return-to 

(defmicro cal l-select-and-PBturn-to (condition true-subroutine false-subroutine return-to) 
Iparaltel ipicroinstruct ion sequencer pushj next-eequence , return-to) 
( I f ,condi t ion 

,{if (atom true-subroutine) Mooto ♦true-subroutine) true-subroutine) 

,(tf tatom false-£u::routine) Mgoto .false-subroutine) false-subroutine)))) 

:ReaMy i f u & no popj. Hardware r.akes the distinction when stack is emotu. 
(defmicro next-instruction (} ^ ^ 

* (microinstruct ion sequencer next-instruct ton)) 

(defmicro increment-pc 
(selectq *machine-version* 

((tr.-.c) • (nicroinstruct ion spec ifu-control eagic 1 magic-mask 1)) 
utmcb) Irnicroinstruction spec ifu-controi magic 3 magic-mask 3)) 
(otheruifse (retch "I don't know how to do this except on THC machine")))) 

; Tetrpcrary L-ntil real IFU 

1 ToKes 2 cycles and can't be done in parallel with other things 
.; Use a subroutine to save microcod* space 
(defmicro increnent-fake-pc 
'(call-select (odd-pc? pc) 

(parallel (assign pc (set-type (1+ pc) dtp-even-pc) ) 

(return)) 
(parallel (assign pc (set-type pc dtp-odd-pc)) 
(return)))) 

\olin'^trT^t^^^^^^^ '°"'"^' °^ °^*"* ""^ '" ^^^"^^ instructions 

' (parallel (+ ,base-pc (rotate ,r.ag!C-of fset 37)) 

(microinstruction forc6-cDu3<33-32> 3))) :dtp-even-pc/dtp-odd-pc 

Add an offset to the PC, using an ordinary number as the offset 
.., offset can bs one argument, or two arnuments (the second being 1) 
;:: Uses b-terr.p-3 (out either argument being b-temp-3 is okay) 
(aefmicro pc-plus-numoer (base-pc &rest offset) 

(sequential (assign b-tefr,p-3 (+ (halfwerd-pc , base-pc) . .offset)) 
(word-pc b-ten:p-3))) 

;This micro assigns to the PC and does whatever else is necessary to make the 
:IFU happy. For now, iust next-instruction. For the T^C IFU, will start a 
;2-word read and wait for the appropriate length of time, then NEXT- INSTRUCT I ON. 
;Other code to be done in parallel with the »emory access say be supplied, 
(defmicro set-pc (neu-pc ioptionai other-code) 
(selectq «m3chine-verBion* 
( (sim proto) 
( i f other-code 

•(sequential (assian pc , neu-pc) 

(parallel .other-code 

(next-instruct ion) ) ) 
•(parallel (assign pc , neu-pc) 

(next-instruct ion) ) ) ) 
((tmc) 
(if (null other-code) ;This instruction is completed, PC may advance 

(para Mel 

(assign pc .new-pc) 
(clear-stack-adjustment) 
(jump ifu-enpty-trap-D) 
* (sequent iai 

(assign vma , neu-pc) jCheck for page fault first, because the TX 
(start-menoru read) ;does not have a separate EPC 
(assign pc .new-pc) ;Now set PC (and VITA again) for real 
(parallel .other-coda 

(start-memory read block instruction-fetch)) 

(start-wemory read block instruct ion-fetch) jActive(l) 

nop) , :D3ta(l),Active(2) 

a. r, <"ext- instruct I on)))) ;aecode(i) ,Data(2) 

I ( tmcD/ 

' (sequential 

(assian pc .neu-pc) {Assign to DPC and VTIA (leave EPC alone) 

(parallel .other-code 

(start-memory read block instruction-fetch)) 
(start-aemory read block instruction-fetch) ;Active(l) 
r'op) , ;0ata(l).Active(2) 

(next-instruct ion))) tDecode(l) ,Data{2) 

(otherwise (retch "-^S machine version not handled yet" »nachine-version*) ) ) ) 

;Set the PC at which execution will restart if this instruction is pclsred 

;No tnstruction fetch is done since that PC will normally not be used 

?j!:?^5V c-It.S? nn ^" *^®" halfword (usually it is an cccape function) 

'z^^*:^. '^^^'^'^*"'^^ ""^* ^^ ^°"® '" ^^^ ^s^t cycle (or some later cycle before it's needed) 

(defmicro restart-pc (neu-pc) 



(selectq «machine-ver8ion* 

(isim proto tnc) ;PC wi M get backed up if pclsr, so advance it 

(assign pc (odd-pc , new-pc))) 
((trrcB I f u) 

'(assign pc (even-pc-except-38-through-2S .new-pc))) 
(otherwise (retch -*.S machine version not handled yet" «machine-version*) ) ) ) 
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jAccept the restart PC into the EPC from the DPC/IPC, and increment the DPC/IPC past it, 

(definicro accept-restart-pc () 
(selectQ «raachine-version» 
((sim proto tmc) ni I ) 

((tmc5 ifu) ' (increment-pc)) ^ . . ».xv 

{otherwise (retch "--S machine version not handled yet" *raachine-version«) ) ) ) 

(defmicpo I i sp (form) 

* (micro instruction escape-to- lisp ,foro}) 

(def micro signal -error (4rest code) 
'(error- if true . ,code)) 

•itrap-if <cond> (signal-error <Brr>)) but saves an instruction 
(defmicro error-if (condition Arest error-code) 
•(parallel (trap-if ^condition (goto error-trap)) 

(microinstruction error-table , (copy list error-code)))) 

(defmicro signal-crror-no-restore-stack (&rest code) 
* (error -no-restore-stacK- i f true . ,code)) 

(defmicro error-no-restore-stacK-i f (condition Arest error-code) 
'(parallel (trcp-if .condition (goto crror-trap-no-restore-stack) ) 
(microinstruction error- table , (copy list error-code))))- 

;*fieid' somehow selects a field 

;It can either be a microdata on the alub, using normal field selection, or 

;it can be a microdata on the alub which selects one of several special sbus 

; fields, or it can oe one of the foMcwing special forms: 

; (cdr-code <a-opnd>) 

; ..more in the future?.. 

;Thc value of the dispatch field in tho resulting code is the symbol alub or 

: one of several special sunibols for the special dispatches, 

; 'clauses* arc something like selectq clauses, car of each one is a 

; lict o.f symbolic or numeric values, cdr of each one is a microcode 

; sequence or a defucode tag, as with IF, 

(defiMcro dispatch-af ter-next (field drest clauses) 

(mul t ip le-value-bind (ufield magic code symbol ic-cues-al i st) 
(expand-dispatch-f ield field) 
'(para I lel 
,cooe 

(microinstruct ion 
dispatch ,ufieid 
magic ♦magic magic-mask 7' 
dispatch-taole I, ufield . 

, (cxpand-dispatch-clauses clauses synboi ic-cues-al ist) ))) )) 

(defmicro di spatch-af ter-thi s (operand this &body clauses) 
' (sequent ia I 

(dispatch-after-next , operand 

, •clauses) 
(parat lel 
.this 
(take-dispatch)))) 

(defun expancJ-d i snatch- fiefd (field Scux efield code tcni table afist) 
{returns dispatch field, Ka9ic nunber field, other microcode, sumbof Ic-cues-al i st 
(setq attst (get (or (oet Iff (sumbolp field) field (car field)! 'enumerated- type-name) 
(and (listp'field) (eq (car field) 'Ido-field) 
(get (caddr field) •enumerated- type-name) )) 
•enumcrat£d-ttjpe-ccdes) ) 
(setq efield (microexpand field)) 

(setq table M(3Aa4 , afcus<31-28>) ;2 array registers 

(2684 , abus<25-22>) :3 array-dispatch 

(2?fi4 . abus<2I-lS>) ;4 array-type 

(CC53 , abu9<2-0>))) ;5 function calling 

(cond {(atom efield) (retch "Garbage dispatch field: -n,S — -S" field efield)) 
:;Speci2l fcrms 
((eq (car efield) *cdr-code} 
(values 'cdr-code 1 icjet-to-abus (cadr efield)) alist)) 
{(not (and (eq (car efteld) *microdata) (eq (cadr efield) 'alub))) 

(retch "Garbage dispatch field: -^S — *S" field efield)) 
;;5pecial abus fields 
((and (fielcp (setq code (caddr efield)) 'ubus 'abus) 

(setq tern (assoc (dpb (- 43 (second (gat code 'byte-func)) ) 

(third (get code 'byte-func))) 
table))) 
(values (cdr tern) 

(+ (f ind-po::i t ion-in- I ist tern table) 2) 
(modify-code code ' ( tybus nil) (byte-func nil))) 
al ist)) 
;;Normal field extraction thrcuqh alub 
(t (values *alub 6 code alist)))/ 

(associate-dispatch-cues cdr-code «cdr-code5«) 

;Car of clause is list cf selectors 

xCdr of clause is body of a sequence, or goto special form like if 
(defun expand-dicpatch-clau-es (c/ausea symbol ic-cues-al i st) 
(mapcar <r* (lambda (clauee) 
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iiist (expand-dispatch-cue5 (car clause) symbol ic-cues-a I ist) 
(cond ((and (» (Irngth clause) 2) 

(not (atom (cadr clause))) 
(eq (caadr clause) 'goto)) 
(cadadr clause)) 
(t (raicroexpand Msequential . , (cdr clause))))))) 
clauses) ) 

(defur. expand-di sDatch-cuss (cues sumDoi ic-cues-al i st) 
(if (eq cues 'otherwise) cues 
( loop for cue i n cues 

collect (cond ((nurnberp cue) cue) 

((cdr (ass'-i cue symbol ic-cues-a I *ist))) 

(t (retch "^S unrecognized dispatch cue" cue)))))) 

;DiBpatch only takes effect if this is executed in the following cycle. 
(def.T.icrc take-dispatch 
'•(microinstruction sequencer take-dispatch)) ;t.e. CPC from tJPC 

;;; Definition of closed ciicrorou tines 

(defprop defucode "Microcode routine" si tdefini t ion-type-name) 
(defprop defucode-at-!oc defucode 2wei :def ini tion-funct ion-spec-type) 
(defppop definct defucode zuci : def ini t icn-funct ion-spcc-typei 
(defprop definstl defucode zwei :def ini t ion-function-spec-type) 

(declare («expr microcode-to-l isp-funct ion ;Suppress compiler uarnincj 
check-fliicrocode)) 

defucode defines a »tcroroutine which can either be jumped to, 
called, or trapped to. *name' is aiwaijs a syr^bol. 
Thfe body has on implicit 'sequential', 
defwacro defucode (name &body bodu) 
(defucode-1 'defucode name body)) 

loc is a number which is either a single location or a list of 
locations; the first microinstruction ui I I be replicated through 
those iocat ions, 
defoccro dafucode-at-loc (name loc dbody body) 
(defucode-1 *defucode-at-loc name body toe)) 

; definst defines the microcode to execute a particular macroinstruction 
; it is very much like defucode but stores the microcode in a different table 
; Put in the (next- instruct ion) yourself if uou need it, or use definstl 
defoacro definst (nane format-and-at tributes Sbodg body) 
(val idate-def inst name format-and-attr ibutes) 

(defucode-1 'definst name body (if (atom format-and-attributes) foraat-and-attributes 

(car format-and-attributes)))) 

;; Like definst but defines a 1-cucle instruction. AM clauses of the body 
'- are done in parallel, and the Tnext- instruct ion) is put in automatically. 



defmacro definstl (name format-and-attributes fibody body) 
Mdefinst .name .format-and-attributes 



(paral lei ,9body 

(next- instruct ion)) )) 

(defun defucode-1 (flavor name body ^optional data) 
(let* {{»:b3ck trace* '((.flavor ,name))) 

(microcode (microexpand * (sequential . .body) ) )) 
(setq *top-level-code* microcode) 
(check-microcode microcode name) 
• (progn 'compi ie 

,«(if (eq data * 13-bit- immediate-operand) 
(loop for i from 8 below 4 

nconc (defucode-2 flavor name microcode data D) 
(defucode-2 flavor name microcode data)) 
'.name))) 

(defun defucode-2 (flavor name microcode data ^optional (offset 8) Aaux (inarae name)) 
(and (piusp offset) (setq iname (f intern "^rA-vQ" name offset))) 
(let (disp-natre (f intern ' i-^A-LISPniCROCCDEI iname))) 
*(,o(cond ((eq *m3chine-version« *sim) 

(nconc (if (eq flavor 'definst) 

(neons '(defprop , iname , lisp-name micro-executor))) 
(neons (microcode-to-l isp-function lisp-name »icrocode ^('Q iname))))) 
,(let ((address-constraint (selectq flavor 

(definst (let ((loc (instruction-dispatch-loc name) ) ) 

{+ loc (« offset 4)))) 
(defucode-at-ioc data) 
(otherwise nil)))) 
' (put-ucode ' , iname 

'.mi crocode 

'.(if (cq *machine-version« 'sim) lisp-name 

(assemb I e-m i cro i nstruct i on-p list i name m i crocode 

•ddress-constraint offset)) 
, »mach i ne- ver s i on*) ) ) ) ) 

(defun put-ucode (tag microcode mi ere I machine-version) 
(or (si :record-source-f i le-name tag 'defucode) 

(ferror nil "Sorry. I already did most of it")) 
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(let ({ucods (assq irachine-versfon «ucode-at ist-al ist*)) tem) 

(or ucode (puch (cetq ucode (cons machine-version nil)) «ucode-al ist-aM st*) ) 
■ (cond (isstq tem (assq tog (cdr ucode))) 
(cctf (cadr ten) microcode) 
(setf (caddr tem) micrel)) 
(t (pu3h (-list tag microcode mi ere!) (cdr ucode))))) 
(setq «need-to-rmk« t) 
tag) 

;Due to universal opcode*, thta works for both nornal and foriiat-3 instructions 
Ids fun instruct ion-di spatch-loc (name) 

(i£n (car (get nams instruct ion-data) ) 2)) 
;;; Reading in of the opcode definitions ftle 

(defaacro defopcode (nane opcode fornat &rest attributes) 
Mdefopcodel \name ', opcode \fortiat ' .attributes) ) 

{defun defopcodel (name opcode format attributes) 

(or (S 8 opcode 377) ;Tcmporsry 8-bit opcodes 

(< 1608 opcode 1377) -But do have S bits of format-S also 
(ferror nil "Opcode ^ for instruction -vS out of range" opcode name)) 
(or iaeoq fornat ' (unsigned- iwmediate-cpcrand signed-immediate-operand 

address-operand no-operand quick-cxternai-cal I constant-operand 
indirect-operand lexical -operand instance-operand 
•icrocode-opersnd uncinned-pc-retat ive sianed-pc-relat ive 
constcnt-pc-reiative Ifi-bi t-i«medicte-opefand) ) 
(ferror ni ! "Format '^3 for instruction ^S not recocnired** format name)) 
(and (bit- test 1C00 opcnd-J 
(neq format 'no-ocerand) 

(ferror nil "Instruction *.S with opcode -vQ auet be NO-OFERAfJD, not -.5" 
name opcode foraat)) 
(loop for attr in attributes do 

(or (»emq attr •(needs-stack aaashes-etack brancn-predict stop-ifu)) 
(and (listp attr) (eq (car attr) 'function) (s 3 (length attr) A)) 
(and (listp attr} (eq (car attr) 'operand) (- (length attr) 2)) 
(ferror nil "Attribute *'S for metruction -5 not reconnized" attr name))) 
(putprop name (list* opcode format attributes) * instruction-data) 
(if (eq forcat '10-bt t-immadiate-operand) 
(loop for i from 1 to 3 

do (aset name »opcode-tabte« i+ opcode i)))) 
(aeet nane »opcode-tabte» opcode)) 

(defun val idate-def inst (name format-and-at tributes) 
(let ((format (if (atom format-and-attr ibutes) format-and-attr ibutes 
(car format-and-attr ibutes))) 
(attributes (if (atom forcat-and-attributes) nil (cdr foPBat-and-attributes)) ) 
(data (get name 'instruction-data))) 
(cond ((null data) 

(ferror nil "^S rot defined in OPDEFS file" name)) 
((neq format (cadr data)) 
(ferror nil "^S in format ^S disagrees with OPDEFS file, which sags ^'S" 
name format (cadr data))) 
:Check attributes that affect the microcode. I think IFU ones don't. 
((loop for attrib in '(needs-stack smashes-stack) 
thereis (neq (not (memq attrib attributes)) 
., . (not (memq attrib (cddr data))))) 
(ferror ni! "Attributes for *S dieagrce with OPDEFS fito" nama))))) 

;;; Reading in of the system definitions files 

(defun sysconstant-eval-fun (type value) 
(selecto type 

(nil (or (get value 'susconstant) 

(car {qet value 'byte-field)) jPPSS 

(ferror nil ''-^S has no DEFSYSCONSTANT nor DEFSYSBYTE value" vnlue))) 
(defsusbute- 1 imi t-value 

(1+ Iby^e-fie Id-ones value))) 
(daf susr.yte-ones 

(byte-f leld-ones value)) 
(def storage-size 

(get V3iue 'dcf storane-size) ) 
(otherwise 
(ferror nil "Do not understand *S for •^S" type value)))) 

(defun bute-fi eld-ones (ref) 
(dpb -I 

(Idb 8005 (car (or (oet ref 'byte-ffeid) 

(ferror nil "-S has no DEFSYSBYTE value" ref)))) 
0)) 

(defmacro defsysconstant (nawe form) 

(setq form (T I c: def sysccnstant-ev?I form ;S?' sysconstant-eval-fun) ) 
* (putprop '.name ' , f orm ' sysconstant) ) 

(defmacro defsysbute (name n-bits bits-over) 

(setq n-bits ( 1 Tc:def succonstant-eval n-bits iSf'sysconstant-eval-fun) ) 
(setq bits-over ( I tctdef sysconstant-eval bits-over i;r' sysconstant-eval-fun) ) 
•(eval-when (compile load evaU 

iputprcp ',name ' (. Ibyte-numbcrs-to-ppss n-bits bits-over)) 'byte-field))) 
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;;; (dctenunsrated list-name (nawes...) [start inq-vaiue] [increment] JcndingvalueJ ) 
;;; start ing-vaiue defaults 0, increment to i 
;;; If endingvalue is supplied, it is error -checked 

(defoacro defenunierated {list-name cods-list fioptional (start C) (increment 1) end) 
(and end im (length code-list) (// (- end start) increrrent)) 
(ferror nil "^S has ^S codes where -S are required" 

''st-naaie (length code-list) (// (- end start) increment))) 
(progn compi le 

(defconst .list-name \code-list) 
(defprop , I i st-name 

.(loop for code in code-list and pre^^ « 8 then code 
as value from start by increment 

unless (eq code prev) ;kludn2 for data- tunas 
collect '(,ccde . , value)) 
enumerated- type-codes) 
;; sycconstant properties are expected by seme embedded expressions 
,«(locp for code in code- list and prev - then code 
as value from start fcu increment 

unless (eq code prev)" ;kludne for data-types 
collect '(putprop \code ', value sysconstant)))) 

;:: (defstcrace (structure-name options.,.) 

;: ; ^ fields...) 

:;; V^^^ " (^sme n-bits r iqht-hand-bi t-numbcr) or a list of subfi-elds. 

;;; Onitting the bit specification gets you a word-filling Lisp object, 

;;; The top-level fields are really words, the rest are packed butes. 

;;; Options: ^ ^ 

;:; BACKWARDS (word offsets count down from instead of up from C) 
• ' * _ 

;;; For the microassembler, this defines def-byte-f ield type accessors 
;;; for the defined bytes, and assumes that the microprocrammer takes 
;;: care of the word offsets. That will do for the eimpTe structures like arraus, 
y,' '7^ offsets do get saved on a word-offset property for possible future use.' 
(local-declare ((special «defstorage-f ie tds*) ) 
(defmacro defstorarje ((structure-name . options) . fields) 
(let ((increment 1) 

(*cjcf£toraqe-f ieldc* nil)) 
idol ist (opt opt ions) 
(seisctq opt 

(backwards (setq increrent -1)) 

(otherwise (ferror nil "DEFSTCFtAGE -S - unrecognized option -^S" structure-name opt)))) 
(progn compi le ^ "^ , ^ 

♦•(loop for field in fields as word from by increment 

nconc (defstorage-f ields field word structure-name)) 
(defprop ,ctructur2-n3me .(length fields) dcf storage-size) 
(defprcp .structure-name **defstorage-f ields* defstorage-f ields) )) ) 

(defun defstorage-f ields (field word structure-name) 

(cond ([or (listp field) (null field)) :untt t listp is fixed... 
l(f (I istp (cor field)) 

(loop for Eubfield in field 

nconc (defstoraqe-f ields subfield word structure-name)) 
(defstorcgs-f ield field word structure-name))) 
It (dcfctorcge-f ield (list field) word structure-name)))) 

(defun defstorane-f ield (field word structure-name) 
ctructure»-n3rr,e ;not csed 
jpu£h (car field) «def storaye-f ie Ids*) 
(list Mdefprcp , (car field) ,word word-offset) 
(and (cdr field) 

Mdef-byte-field .(car field) .(cdr field) place)))) 
); I oca I -dec I are 

;£xtract word offset for a field; u»e this inside an a-constant or b-constant for» 

(defun f leld-tjord-of fset (name) 
(or (get name 'word-offset) 

(terror nil "^S has no word-offset; probab/y not defined with DEFSTORAGE" name))) 

(defvar wescape-funct ion-next-pc-locat ion*) 

;Define a-memory locations that are used microcode/Li so communication 

;If the merocode wants to initialize these, it can defcreg them itself; 

;that defareg will get put in the same address. 

(defmacro def ine-maqic-locat ions ((block-name . options) dbody slots 4aux tem) 

(cond (Jseto tem (get (locf options) •a-memory-address) ) jinteresting to microcode'^ 
(if (eq block-name 'nicrocode-escape-rout ines) 

(setq *e5cape-funct ion-next-pc- location* tem)) 
• (progn *compi te 

(defprop .block-name .tern a-memory-b lock-address) 
- ,(ioop for slot in slots as loc upfrom tem 

collect ' (defareg-at-loc .(if (sumbolp slot) slot 

(intern (format nil "^.A—^A" 
,,,, (car slot) (cadr slot)))) 

,, , . (oc)))) 

Hsetq tem (get (locf options) 'virtual-address)) 
* (progn 'compi le 

. .(loop for slot in slots as loc upfrom tern 

collect Mdefprop .slot .loc virtual-address)))))) 
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;Define a-ncnopy locations that hold PC's of escape functions 

. Someone needs to store an initial value for the eimulatop 

(def macro def ine-escape-f unci ion (name doody ignore) 
(let ((a-irem-p t)) 
(cond {(1 istp name) 

(dolist (opt (cdr name)) 
(selectq opt 

(no-a-memory (setq a-mem-p nil)) 
(wired ) 

(otheruise (f error nil "Unknoun keyword *5 opt)))) 
(setq name (car name)))) 
(and a-mem-p _«_.__ «^-,, 

(progl Mdefareg-at-loc .(intern (string-append nare "-ESCAPE-PC )) 

,*esc3pe-f unct r on-nex t-pc- i ocat i on*) 
( incf «escape-functi on-nex t-pc- location*) ) ) ) ) 

F:>1mach>ucode>UL. LISP. 167 

;;; -»- f1ode:Ltsp; PackaoetMicro; Base:8; Lowercase:ye3 -«- 
;;; (c) Copyright 13£2i. SyfiiOot.ics, inc. 

; nicrocode to Lisp translator (wakes Lisp that u\ il run with Slfl) 



;The order of the dofconsts is the order of execution in the Lisp, 
(def const read-phase-f ie I riD 

• tGbus amem-reaci-3ddr bbus brem-resd-addr xDus ybus) ) 

(defconst data-path-fields 
' (alu byte-func)) 

(defconst force-obus-f \elds 

Mforce-obu3<35-o4> force-obus<23-32> forcG-obus<31-28>) ) 

(defconst trap-phase-f ields 

Mtype-aap trap-enables trsp-sequence ar i th-trap-di»patch-table) ) 

(defconst operate-phase-f ields 

•(dispatch dispatch-table escape-to- I isp error-table)) 

(defconst reoister-u'r i te-f telds 

•(write-amem amem-ur i te-addr urite-bmem bmem-wr i te-addr 
write-ibus lous-dev-addr mem stack-pointer)) 

(defconst jump-phase-f tetds 

•(sequencer justp-secuonce ne«t-sequence condition 
skip-true-sequence skip-fa/se-sequence) ) 

(defconst al 1-over-the-piace-f ields 

•(spec aogic Bagic-mask declare-meniory-tttBing unique speed)) 

(defvar »microI i sp-funct i on-name*) 
(declare (special *backtrace*) ) ;InUU 
(defvar *ffilcroinstruct ion*) 

(defun bletch (format-string &rest arcs) 

(declare (special args)) ;Fcr accessibility from breakpoint 
(let m (("w nil) (-"r nil) (^q nil)) 
#Q ((msgfiles error-output)) 
(format mGgfilcG ''^>>Error: ") 

(lexpr-funcai 1 ^' format msgfiies format-string args) 
<for«at Ksgftles *'*-& Uhile coxpilinn nicrocooe to lisp for *S" 

«m i cro i i eo-funct i on-nanie*) 
(format msgfiles "^ flicroinstruct ton; ^^S" «wi cro instruct ion*) 
(fortsat msgfiles "-^ fltcroexpand backtrace; ^{^<^X #^2: ;^*«>*'*', *►)**** 

*backtrace*) 
(break bletch t))) 

;selectq uith appropriate error processing 
(def macro eselectq (valname val £rest ctauces) 
(let ( (ni I -present (loop for (key) in causes 

thereis (or (eq key nil) (and (I istp key) (nemq nit key)))))) 
'(celectq ,val 
^•clauses 

,«f(and (not nil -present) *(((nil> ni!))) 
lothcruise (bletch ".^-S invalid value for ^^S" ,val ', vat name) ))) ) 

(defun uksetq (var val) 

(and val (neons Msetq .var ,val)))) 

(defun mksetq2 (varl var2 val) 

(and vai (neons * (setq ,v3rl (setq .var2 ,vai))))) 
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(defvar «dirpatch-deslinatiGn« nil) 

(dec 1 are-spec i a i squi d) 

(defun eval-at-!oad-t (pe (fcrr) 
(cond ((ctstuE feoture compir) 
( i i st 5:;u I d f orn) J 
(t (eval forr.i)))) 

(defun eval-at-l03ri-t fine (forr) 

**,(if <and corr.D 1 I er:qc-fi le-i n-prorres3 (not cornpHer:qc-f i le-load-f lag) ) 
(cons corpi ler:evat-2t-load-: iris-marksr form) 
(eva I form) ) ) 

(declare {%cx;'r fieldp)) ;in U'J 
•Simulation routines for shifter 

m 

(declare (fixnua (rot32 fixnum fixnum) 
(ash32 fixnum fixnun) 
(mer(3fi32 fixnum ftxnum fixnum) 
(waskSZ fixnum)) 
(special *pc«) ) ; in Sin 

(eval-uhen (eval compi te load) 
(defun ash22 (value ar^ount) 

(ash (logand value n.Vi- 1_32.)) amount)) 
) ;eval -uhen 

(defun rot32 (value anount) 

(seta amount (logand 37 amount)) 

JW1 (dpb value (+ (ish amount S) (- A0 amount)) 

(Idb (+ (Ish (- 42 amount) 6) amount) value)) 
i»Q (logior (loc^nd (a3h32 value amount) tf. (1- 1 32.)) 

(locjand (ash32 value (- amount 48)) Tl- (ash 1 amount))))) 

(defun mask32 (nbits) 
(1- (ash 1 nbits))) 

(defun meroG32 (shifted mask unshifted) 
(logior llogand rr.asK shifted) 

(logand (lognot mask) unshifted))) 

;hore simulation routines. These are used instead of open-coding 
; things so that ncompir doesn't expand r.ij code by a factor of 1£3 

(declare (muzzled t) ;Don't give »e a hard time about haulong 

(load *8im) ;Get certain cacros needed belou 

(fixnum (address-add-fp fixnurn) 

(address-acid-sD fixnum? 

(oddress-add-macrocode) 

(aref-amem tixnur.i) 

(aref-b-em fixnum) 

(aref-bmeni-3DQ) 

(IS-bi t-sign-extend fixnum)) 
(notype (aset-amem fixnum fixnum) 

(aset-bmem fixnum fixnum) 

(aset-bmem-3fc3 fixnum) 

(setq-vma fixnum) 

(setq-fp f ixnum) 

(setq-sp fixnum) 

(carry2S fixnum fixnum fixnum) 

(carry32 fixnum fixnum fixnum))) 
(declare (special *frame-pointer« «stack-pointer« *xbas« »pc« *vma« *pmaiE *instruct ion* 
*a-memoru* *b-memory* «byte-r« «byte-s* «type-map« 
«multiply-x* *Tnu 1 1 i p I y-y* *t ast-error-table-entry-seen*) ) 

tfn 

(declare («lexpr address-add) 

(*expr even- instruct ion odd- instruct ion instruction-opcode 

instruct icn-uns igned- i mmediate instruct ion-signed-i remediate 
pc-3dd instruct ion-bassno instruction-offset itack-address 
set-pma-from-vma) 
(f ixnum (even- instruct ton fixnum) (odd- instruct ion fixnum) 

( instruct ion-opcode) ( instruct ton-unsigned- immediate) 
( instruct ion-signed-immediate) (pc-add fixnum fixnum) 
( instruct ion-baseno) ( instruct ion-offset) 
(stack-address fixnun) (address-add notype fixnum))) 

(defun address-add-fp (offset) 

(address-add *«fra5]e-po inter* offset)) 

(defun address-add-sp (offset) 

(address-add **stacK-pointer* offset)) 

(defun address-add-xb (offset) 
(address-add '*xbaE* offset)) 
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(def'jn address-arfd-macrocods 

(address-add ( instruct ion-t>aseno) ( instruct ion-of feet) t) ) 

<defun aref-amew ( loc) 
iarei *a-memoru* loc)) 

idcfun aref-bmen (loc) 
(aref *D-neniory« ioc)) 

(defun 3ref-t>mcni-3PS 
(aref *b-tnemoryx 3E8) ) 

<defun acct-amen (va! ice) 
(aset vai «a-menory* !oc) 
ni I) 

(def'jn 2f3t-bmeni (val iorr) 
(asct va I »J:;-ir.er;cru» t cc) 
nli) 

(defun aset-bmem-3G0 (vai) 
(aset val »b-meniory« 3B0) 
ni I) 

(defun setq-vna (obus) 

(setq »vm3» (pointer-field obus)) 

;nappinq, which realiy happens in thu next cycle 

jHao ciiss trap is not simulated, happens when memonj-data read op written 

(set-pma-from-vir.a) ) 

(defun setn-sp (obus) 

tsetq «st£ck-pointcr* (pointer-field cbus))) 

(defun setq-fp (obus) 

(setq *fraJr:e-pointer* (pointer-f /el d cbus))) 

(defun inc-sp 

(setq «3tacK-pornter« (1+ *stack.-pointer*) ) ) 

(defun dec-sp () 

(setq astacK-pointer* (1- «st3c*^-pointer*) ) ) 

(defun inc-macro 

(setq »instruct ion* (1+ *instruct i on*) ) ) 

tSimulate ALU carry function 
(defun carry2S (x y z) 

(bit-test 1^28. (+ (logand tt.il- 1_2S.) x) (logand tt,il- 1_2S.) y) 2))) 

(defun C3rry32 (x y r) 
(bit-test 1.32. U (logand ^.(1- 1.32.) x) (togand ttAU 1_22.) y) 2))) 

;One simulation routine to help with Bultiplier 
(defun 16-bi t-sian-extend (n) 

(if (bit-test I_15. n) (+ 177777_16. n) n) ) 

;Returns a (defun nawe — translated-microcode— ) 

(defun »icrocode-to- I i sp-funct ion (name eicrocode ffU dof mi t lon-name) 
(let ((«microl isp-function-naBe« name)) 
• (defun ,name 



rerun , n^me \t ,. , . » , 

J?Q (declare (sys: function-parent ,def mi t lon-nane) ) 
(prog (abus bbus xbus gbus alub obus dispatch alu-output type-map) 
W1 (declare (fixnum abus bbus xbus ybus alub obus diepatch alu-output typ©-«ap) ) 
(proon abus bbus xbus ybus alub obus dispatch alu-output type-map) {inhibit u^rnir 
(setq type-map 6) ; Idiot comoiler warning in tlactisp, code bug m Liep (lachine 
. , (microcode-to-l isp wicrocode))))) 



(defun microcode- to- I irp (microcode) 

tcond ((eq icar microcode) '(nicrosequence) 
(loop for X in {z6r aicrocode) 

nconc (microccde-to-l t rp x))) 
((eq (car microcode) 'microinstruction) 
(let ( («niicro instruct ion* microcode) ) 
(micro) i sp-syntax-check. microcode) 
(nconc (microl isp-read-ph02e microcode) 

(micro! i sp-data-path-phase microcode) 
(micro! isp-force-obus-phase microcode) 
(micro I i sp-trap-phase microcode) 
(microl isp-operate-phase microcode) 
(micro! tsp-regi ster-ur i te-phase microcode) 
(microl i sp- jump-phase microcode) ) ) ) 
(t (b I etch "Unrecognizable laicrocode: ^S" microcode)))) 

(defun microl i sp-syntax-check (code) 

(loop for (prep val) on (cdr code) by *cddr 

unless (or (memq prop read-phase-fields) 

(memq prop data-path-fields) 

(memq prop force-obus-f ieids) 

(memq prop trap-phase-f leids) 

(memq prop operate-phase-f ields) 

(memq prop rcgi ster-wri te-f ields) 
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(flierr.q prop jump-phase-fields) 
(msr.q prop al l-ovep-the-p!ace-f ields) ) 
do (b I etch "Unrecognized microcode field: ^S" prop))) 

:Generate setcs of the varia&les SDur. bbuc. Kbus. ubus 

ioefun »t cro I i sp-read-phase (code) 
(nconc 

imksetq 'aous 

ieselectq abus (get code *abus) 
tameni 

(let ({addr (get code *aiDem-read-addr} ) ) 

(if (and (not (atom addr)) (eq (car addr) •constant)) (cadr addr) 
Maref-amcm , (amcmaddr addr))))) 
(memory-data * (pma-mem-read) ) 
(frame-pointer **frame-po inter*) 
(stack-pointer *«stacK-pointer*) 
(vn.a *»viri3«) . 
(fc **pc*} ) ) 
(mkseta *bbus 

(eseiectq bbus (get code 'bbua) 
(bnen 

(let ((addr (get code ' bmem-read-addr) ) ) 

(cond ((and (not (atom addr)) (cq (car addr) 'constant) ) 
(cadr addr)) 
((■ addr 2b21 
'(aref-bmem-SSa)) 
(t Maref-bnem ,addr))))) 
(macro-sicined-iramedi ate '( instruct ion-signed-innediate) ) 
(macro-unsigned- immediate * ( instruct Jon-unsigned-immediatc) ) ) ) 
(mKcetq *xbus 

leseiectq xbus (get code *xbus) 
(abus 'abus) 
(bbus 'bbus) 

(product '(« *Truftipiy-x« «mu 1 1 iply-ynt) ) ) ) 
(mksetq *ybus 

(eselectq ybus (get code 'ybus) 
(abus *ac?us) 
(bbus *bbus) 

; This is really not right, but will do for nou I guess 

(ybus-crocKs-1 '(a^hSZ abus -^2.)))))) 

:Ger.erate setas of the variables alub, alu-outout, and obus 

ioctu"^ ffiicroi isp-data-p3th-ph3se (code daux tem) 
tncc-.c 

(if (£s:q tern (get code 'byte-func)) ;Using the shifter 
i^^setq * a i ub 

(if (eq tern 'ybus) *ybus 
Imake-a I ub-G 1 gn-nack 
(make-mcrgs 

(make-rot 'ybus (fix-bytff-r (second tern))) 
(if (eq (first ten) *dpb) ;rotate-rask 

Imake-rot (make-mask (f ix-byte-s (third tern) ) ) 
(fix-byte-r (second tern))) 
(make-mask (f ix-byte-s (third tem)))) 
(if (eq (fourth tern) * merge) 'xbus B) ) 
(fieldp code * epec *alub-6ign-hack) ) ) ) ) 
(»ksetq2 'obus 'alu-output 

(eselectq alu (setq tern (get code 'alu)) 
(xbus *xbu3) 
(alub *alub) 

((X+1 X+1-overf lou) M1+ xbus)) 
((X-1 X-1-ovcrf low) Ml- xbuc)) 
({X+Y X+Y-overf low) * (+ xbus alu^)) 
{(X-Y X-Y-overf low) ' (- xbus alub)) 
(X+Y+1 '(+ xbus alub D) 
(X-Y-l •(- xbus alub D) 

(X-Y-signeci * (- (lonxor xbus 1_31.) (lonxor alub 1 31-))) 
(X-Y-1-signed * (- (lonxor xbus 1_31.) (logxor alub~l 3U 1)) 
(and Mlogand xbus alub)) 
(nand MIognot (loocnd xbus alub))) 
(ior Mloglor xbus'alub)) 
(xor Miocjxor xbus alub)) 
(andcy '(Togand xbus (lognot alub))))))) 

;Generate calls to «ercs32, rot32, and mask32 but try to do them at 
•compile time if possible 
(defun make-mack (n-bits) 

(if (nuroberp n-bits) (mask32 n-bits) * («a8k32 ,n-bits))) 

(defun make-rot (value n-bits) 
(cond ((equal n-bits 0) 
value) 
((and (numberp value) (numberp n-bits)) 

(rot32 value n-bits)) 
(t Mrot32 , value , n-bits)))) 
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(defun ■ake-merge (foreground mask background) 
Iproa (tcit!) 
;:Try to use ieh (ash) right instead of rot left, and open-code 
;;when doing a sin:ple byte extraction 
(and (nurrberp mask) (ecual background 8) 

(cond ((and (not (atom foreground)) (eq (car foreqround) 'rot22)) 
(and (number p (setq te::i (caddr foreground) )) 
(or (zerop te-rj) (<- (haulong mask) tem)) 
(return '(logand .(if (zerop tern) (cadr foreground) 
' (ash52 , (cadr foreoround) 
, (- tem 32.))r 
,mask) ))) 
(t (return '(logand .foreground .tiask))))) 
;Uncpt imizab le 
(return * (inerge32 .foreground .mask # background) )) ) 

(defun make-alub-sign-hack (code hack) 
(if (not hack) code 

* ( logxor 1 .code) ) ) 

Valid forms for addr zret 

(frame-pointer f ixnun) 
(stack-pointer f ixnum) 
(xbas fixnum) 
(macrocode) 

fixnum ; between and 7777 I guess 

(constant value) 
(defun anemaddr (addr) 

(cond ((numberp addr) addr) 

((atom addr) (bletch **Garbane amem address: -^S** addr)) 
((eq (car addr) 'frame-pointer) 

* (address-add-fp .(cadr addr))) 
((eq (car addr) ^stack-pointer) 

Maddress-aad-sp .(cadr addr))} . 
((eq (car addr) ^xbas) 

• (address-odd-xb .(cadr adar))) 
((eq (car addr) 'macrocode) 

(if (cdr addr) (bietch "Obsolete amem address: *S" addr)) 

* (address-add-macrocode) ) 
(t (bletch "Garbage amem address: ^-S" addr)))) 

(defun fix-byte-r (r) 

(cond ((and (fixp r) (>- r 0) (<• r 27)) r) 
((eq r 'byte-r) '^byte-r*) 

((eq r 'macro) Mlogand 37 ( instruct ion-unsigned-immediato) ) ) 
(t (bletch "Illegal byte rotation: -^S" r))}) 

(defun fix-byte-s (s) 

(cond ((and (fixp s) (> s 0) (<- s ^0)) s) 
((oq s 'bute-s) * (1+ *byte-s*)) 
( (eq s 'macro) * (+ ( i ch (iooand (instruction-opcode) 3) 3) 

(logand 7 ( I £h ( instruct i on-unsigned- immediate) 

-5)) 
D) 
(t (bletch "Illegal byte size: -S" s)))) 

(let ((liask (dpb -1 field 0)) 
(pos (Ish field -G)) 
(size (Ic-and field 77))) 
(cond ((numberp val ) 

(cond ((zerop vat) *( logand .(lognot mask) .background)) 

((- val (1- (ash 1 size))) Mlogior .mask .background)) 
(t Mlogior . (ach32 val pos) 

(logand .(lognot wask) .background))))) 
((memq val ' (abus bbucT) 

'dOQior (logand .mask ,val) (logand .(lognot mask) .background))) 
((eq val '«er,cry-data) 
' ( I og i or (I cr-jr.d . mask (pma-mem-read) ) 

(logand .(lognot ma^k) .background))) 
( (eq vai icar hair) ) 
*(icglor (logand .(lognot rssk) .background) 

(asn32 (legend .(cadr hair) , (caddr hair)) , (cadddr hair)))) 
(t (bletch "-^S ii legal forcing value — gendpb" val))))) 

(defun ■icrol isp-fcrce-obus-phase (code &aux tem) 
(nconc (and (setq tem (oet code ' forcs-obus<31-2S>) ) 

(nccns '(setq obus . (oendpb te:n 3A04 'obus nil)))) 
(and (setq tem (get code ' force-obus<33-32>) ) 

(neons '(setq obus , (gendpb tern 4002 'obus 

• (bbu5<5-4> bbus B0 2S.))))) 
(and (setq tem (get code * force-obus<35-34>) ) 

(neons *(setq obus .(gendpb tem 4232 'obus 

Mbbus<7-G> bbus 300 28. )))))) ) 
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(dcfun nicrol isp-lrap-phase (code &aux tea traps handler) 
(setq traps (get code 'trap-enables) 

handler (cond ((seta handler (get cod© * trap-sequence) ) 
(if (atca handler) 

* (return (» (nicrocode-l isp- function-name 

handler))) 
Mprogn . .( microcode- to- I i sp handler)))) 
((setq handler (est codw ' ar i th-trap-di spatch-tsb! e) ) 
'(caseq-that-works (+ (logand (ash abus -33.) 14) ;a9h considered 
(loa3nd (a<;h fcbus -32.) 3)) ;harmful. 
. , (nicrol isp-dicpatch-clavise3 handler))})) 

(nconc 
;; Lower-level traps 
(and (setq tern (get code 'type-itap)) 
(neons *(if (zerop Uogand 

(setq type-map 

(arraycaff fixnum « type-nap* 

(•f « (eval-at-load-t tine 

MIsh (assign-tyoe-uai^ '.tern) B) ) 
(logand (ash aisus -23.) /7)))} 
4)) 
(data- type-trap)))) ; — Don't •iaulate trap yet 
;; Higher- 1 eve I traps 

(and handler , , . . . . , 

(neons '(and (or , (and (raemq 'condition-true traps) 

(licpi fy-condi tion code)) 
, (and (meniq 'condition-false traps) 

*(not J (I iepi fy-condi tion code))) 
, {and (meirq type-condition traps) 

'(bit-test 1 type-msp)) 
, (and (uemq 'bbus-non-f ixnum traps) 

•(not (data-type? bous dtp-fix))) 
, (and (memq •overflow traps) 

Moverflow-p alu-output) ) ) 
.handler))) 
.. — traps not done at all: 
s: transport, any-stack, other-stac)^* aap-Biss 

(defun data-tupe-trap 

(cerror T (7 * :data-type-trap "Data type trap")) 

(defvar «type-«ap« («array nil 'fixnum 432S,)) ;3 bits per efernent, cond*4+trap 

(defvar »type-maps» nil) 

<ff1 (declare (*cxpr type-«ap-!ookup) ) ;inUU 

;Note that the Trap bit is complemented 

(def const tyoe-map-encodings .^ 

M(() . 4) ((ccnd) - 5) ((pointer) . B) ((cond pointer) . 7) 

((pointer cond) . 7) ((trsp-0) . B) ((trap-1) . 1) 

((trap-2 pointer) . 2) ((pointer trcp-2) . 2) 

((trap-3 pointer) • 3) ((pointer trap-S) . 3))) 

(defun assign-type-map (map) 

(loop as number « 9 then (1+ number) 
for mapl in *type-map5* 
uhen (equal -type-maps map mapl) 

return number * « 

finally (or (< number 180) (ferror nil "Gleep! Out of typo maps")) 
(setq «type-m3ps» (nconc «typa-«3ps* Incons map))) 
(loop for tupe in *data-types« 

as index upfrom ( I sh number G) 

as outputs ■ (type-map- lookup type map) 

do (store (arraucal 1 fixnum «type-nap* index) 

(or (cdr (assoc outputs type-map-encodtngs) ) 
(ferror nil "^S garbace in typa map" 

outputs)} n 

(return number) ) ) 

(defun equal -type-maps (mapl map2) 
(loop for type in »:dota-tuDes* 

aluags (equal (type-map- lookup type uapl) (type-map- lookup type map2)))} 
(defun aicrol isp-ooerate-phase (code Saux tem) 
(nconc (cond ((setq tem (ret code 'dispatch)) 

(setq »dt6patch-destin3t ion» (get coda 'dispatch-table)) 
(neons *(setq dispatch , (di spatch- I db ten))))) 
(and (setq tem (qet code 'escape- to-1 I sp) ) 

(neons tem)) 
(and (setq tern (get code 'error-table)) 

(neons '(setq «last-error-table-entry-secn« 'ttera))))) 

(defun dispatch-ldb (field) 
(eselectq dispatch field 
(cdr-code MIdb 4282 abus)) 
(abus<31-28> Mldb 3^C4 abus)) 
{abus<25-22> MIdb 2B84 acus)) 
(abus<21-l&> MIdb 2284 abus)) 
(abus<2-0> MIdb 8233 abus)) 
(alub *alub))) 
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(defun »icpo! i 
;F»r3t write 
(nconc (and 



(and 



(fieldp code 



«p-register-up t te-phase (code 4aux te»i leml) 
the ricmories, then the registers (they night address the nemopy) 
(get code 'up ite-amem) 
(neons '(aset-amen obus 

, (afTiemaddp (get code *a9iei«-wpi te-addp)) ))) 
(setq tem (aet code 'up i te-bmemT) 

(neons (if T» (setq teml (get code *b«eni-upi te-addp) ) 3S3} 
'(aset-bfnem-3G8 ,tem) 
•(asct-bmem , tea .teoil)))) 
(get code 'wpite-lbus) 

(symbolp (aet code * Ibus-dev-addp) ) :tgnope non-si»ulatable haip. 
(eselcctq Igct code * Ibus-dev-addp) (get code ' Ibus-dev-addp) 
(upi te-Biemopy (neons ' (pma-»e»-wri te obus))) 
(wptte-pc (neons '(setq «pc» obus))) 
(increment-r.acpo-iBffiediate (neons *(inc-»acPo))))) 
(fieldp code 'weri 'wpite-vBia) 
(neons Msetq-vnia obus))) 
(fieldp code 'spec * incpe«ent-pe) 
(neons * ( »nc-pe) ) ) 
(fieldp code spec * load-fpsip) 
(neons Msetq-fp obus))) 
(fieldp code 'spec 'ioad-stkp) 
(neons '(setq-sp obus))) 
(setq tea (get code *staek-pointep) ) 
(neons (if (eq tem 'incpement) Minc-sp) Mdec-sp)))) 
(fieldp code 'spec ' load-bwte-p) 

(neons (eond ((zepop (loqand 19 (op (get code *«agic) 0))) 
•(setq «byte-p» (locjand 37 obus))) 
((aet code 'dicpatchl 

•Isetq «byte-p« (appay-index-sht f t-prom dispatch))) 
(t (b letch "bute-p-fpow-appay-disp without dispatch"))))) 
'spec • load-by te-s) 
(neons Meetq *byte-s« (logand 37 obus)))) 
(fieidp code 'spec ' toad-xbas) 
(neons '(setq «xbas« (iooand 1777 obus)))) 
(fieldp code 'spec 'load-inst) itempopapy ■enopy contpol 
(neons '(setq «)nstpuet ion« obus))) 
(op (fteldp code 'spec 'multiply) 

(fieldp code 'spec 'multiply-and- type-check)) 
(bit-test i (get code 'magic)) 
(neons '(setq *multiplu-x* 

♦(if (bit-test 4 (get code '«agic>) 

'(16-bit-s ion-ex tend (logand 177777 xbus) ) 
M iooand 177777 xbus))))) 
(op (fieldp code 'spec multiply) 

(fieldp code 'spec 'muttipl 
(bit-test 1 (get code 'magic)) 
(neons • (setq *rul tipty-4* 

,(if (bit-teot 10 (get code 'Magic)) 
• (IG-b i t-s i gn-extend 

(logand 177777 (arh22 ybus -IS.))) 
'demand 177777 (ash32 ybus -16.)))))))) 

;!f eequencep is take-dt spateh then Me ape supposed to take a dispatch 
; deferred fpom the ppevious instpueticn. The co«pi le-t i«ie vap table 
;¥di spateh-deot inat ion-r and the puntime vap i able dispatch contPol this. 
;Note that these have to be ppescpved apppoppiately through skips. 

;If thcpe is a skip on the condition field then we do that. 

;0thepui5c the seouenccp, jump-sequence, and next-sequc^nce fields contPOl 

;cai 1/ jur.p/petupn/next-instpuct ion uhich tupns into Lisp function cal I inq, 

;Ue don't support stnul taneou-j skipping and jumping (yet), except a little fOP cal I -select. 

;At this level ue don't worry about the CPC and HPZ pegi steps 

(defun tnicpol iep- jump-phase (code Aaux jump next) 
(setq jump <get code ' junp-sequence) 

next igot code 'next-sequence)) 
(nccnc 

(eeeleetq (get code 'sequenccp) (get code 'sequencer) 

((popj next-instPuct ion) (ncona * (return nil))) ;next-instpuct ion or petupn 
(nil land next (neons ' (petupn (, (micpocode-l isp-funct ion-name next) ) ) ) ) ) 
((pushi push j-petupn-di spateh) 
(and lump ;cou]d be call-select ... 

tncons (if next * (ppogn (, (micpoeode-l icp-funct ion-name jump)) 

(, (micpocode-l isp-funct ion-name next) ) ) 
• (, (wicpocode-l i sp-f unet ion-name jump) ) ) ) ) ) 
(take-di spateh 

(neons '(caseq dispatch jcaseq because of numbep? 

• , (aicpol i sp-di spatch-ctauses «dispatch-d&3t inat icn*) ) ) ) ) 
(and (fieldp code 'sequencer 'puciij-petupn-di spateh) 

(neons '(caseq dispoteh teaseq becaure of numbers 

. . (micro I isp-dispatch-clauses «di cp3tch-ac5t inat ion*) ) )) 
(and (get! code (sk tp-true-secuencs sK ip-f a! se-sequcnce) ) 
;;pped gets predicate which is t if we should Gkip 
(let { (pred (i icpi ty-ccndi tion code) ) 

(pending-di sp «di spatch-dest inat ion*) } 
(let ((skip-code " iconti C.pred 



(and 



(and 
(and 
(and 
(and 
(and 
(and 



(and 

(and 
(and 
(and 



(and 



(fieldp code 'spec 'mul tiply-and-type-check)) 
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. , (micro J isp- If -branch 

(get code ' ekip- true-sequence) ) ) 
(t , , (let ( («cii spatch-dest inat ion* pendlng-disp) ) 
(Bicrol isp- if -branch 

(get code ' eki p-f a lee-sequence) ))))) ) 
(and (not jump) (fieldp code 'sequencer 'pushj) 

(eetq skip-code Mppog-O , skip-code) ) ) 
(neons skip-code)))))) 

(defun dispatch-cues (cues) 

(cond (IriQ cues 'otheruise) t) ;CASEQ uants T, not 0THERUI3E 
( (atom cues) 

(oletch "dispatch cue -S: must be list or OTHERUISE" cues)) 
(t (mapcar ;S?* dispatch-cue cues)))) 

(defun dispatch-cue (item) 
(cond ((numoerp item) item) 

(t (bietch "-.S illegal as dispatch cue" item)))) 

(defun micro! i«p-dispatch-c I auses (table) 
(loop for clause in (cdr table) 

collect (cons (dispatch-cues (car clause)) 

(cond {(atom (cadr clause)) ;goto 
•((return 

(, (microcode- I isp-funct ion-name 
(cadr clause)))))) 
(t (microcode-to-1 isp (cadr clause))))))) 



(defmacro caseq-that-uorks (value . clauses) 
(if (and (• ilength clauses) 1) 
(eq (caar clauses) t)) 
* (progn . , (cdar clauses)) 
Mcaseq , value . , clauses))) 

(defun I i spi fy-condi t ion (code &aux tern) 
(selectq (setq tern (got code 'condition}) 
(tupe-condi t ion 

*Ibit-test 1 type-map)} 
((not-cdr-0 not-cdr-1 not-cdr-2 not-cdr-3) 
•(not (cdr-code? abus , (f ihd-posi t ion-in-/ ist tera 

• (not-cdr-0 not-cdr-l not-cdr-2 not-cdr-3))))) 
(ubus-31 

""(not (zerop (logandl_31. ubus)))) 
(alu-21 

'(not (zerop (logandl_31. alu-output) ) ) ) 
(alub-d 

•(not (zerop (togand 1 alub)))) 
(other tii se 
( I i sp i f y-a 1 u-cond i 1 1 on 
teni (get coda 'aiu))))) 

(defun I ispi fy-ai u-cond 1 1 ion (cond alu) 
(selectq ccnd 
(equal-pointer 

M. (io^snd #.(1- 1_28.) alu-output) tiAl- 1_2S.))) 
(not-equal-f ixnun 

'(not {- (logand #.(1- 1.32.) alu-output) #.(1- 1 32.)))) 
(not-equa I -typed-po i ntcr 

•(not (. (icaand ff. (1- 1,34.) alu-output) tt.il- 1.34.)))) 
( (not -grnater -pointer not-greater-f ixnun-unsigned) 
(let (icpl 'xbus) cp2 {cp3 0) 

(tunc (if (eq cona * not-greater-pointer) *carry2S •c3rry32))) 
(setq op2 (selectq aiu 
(X+Y •alub) 

(X+Y+l (setq cp3 1) 'alub) 
({X-Y-1 X-Y-l-5inned) •(loqnot alub)) 
((X-Y X-Y-signedJ (setq op3 1) '(Icgnot alub)) 
(X 0) '' 

(X+1 1) 
(X-1 -1) 
(otherwise 
(bietch "^S - bad alu op - Mepi fy-alu-condi t ion" alu)))) 
•(not (,func ,od1 ,op2 ,op3in) 
(otherwise (bietch ^*S - bad skip cond - M spi fy-a(u-condi t ion" cond)))) 

(defun micro! t sp-i f-branch (code) 

(cond ((null code) nil) ;dPop through 

( (atom code) :goto 

(neons • (return (^ (microcode- 1 i sp-funct ion-name code) ) ) ) ) 
(t (microcode-to-i I sp code)))) : immediate code 

(defun raicrocode-l J sp-funct i on-name (utarj) 

(cr (symbolp utag) (bietch "--S - not a' tag — mi crocode- 1 isp-funct ion-name" 

utaa) ) 
(intern (format nil * i^A-LISPMlCROCOOEl utag) ) ) 
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F:>lniach>ucode>trtp.lisp.8 

... -»- flodetLisp; PacKaoezMicPo: Baee;S; Louercaftezyes -«- 
III (c) Copyright 13S2» Symbolics. Inc. 

; riicrocode for Trap Handling on "real" «achtne 
•Get defmicro and alt his hosts 

(declare (cond ((not (status feature tn-.ucode)) 
(load 'udcls)))) 

; Invisible-pointer traps 

;If transporting was needed, it has happened already 
•Tiffic* 2 cucles trappino + 3 cucles here 
<defucode-at-(oc inviz-trap 18305 ;trap-2 handler 
(para I lei 

(dec'?are-memory-ti«ing data-cucie) ;dcfG3t error checking, only used in cnulator task 
(aasian vcia memory-data) 

(if (data-type? nemory-data dtp-body-foruard) 
;; Body forward points to header forward 
(sequential 

(start-memory read) _ «.. x . . * ^ 

(assign b-v«a (- b-vma v«a) ) ;0f feet into structure 
(mach I ne-ver s i on-case 
i(tmc tmc5) 
(secuent i a I 

(assign b-vira C+ «e«ory-data b-vwa)> ; Address word in target structure 
(assign vma b-vnra) ) 1 

°(ass'i'gn vma (+ memory-data b-vma)))}) ;Address word in target structure 
(drop-throuch) ) ) 
(trap-restore 

(start-memory read) 
(assign b-vma vma) )) 

; Invisible pointer following when VMA advanced one or two words in block read, 
;evcp and one-q- forward leave the oriainal seauence intact, the others change 
; to a new sequence. 

(defuccde-at-loc error- trap 12334 ;trap-0 handler 

(paral lei (trap-save) 

(lisp (enter-errcr-handlcr)) j. ^ ^-^ ^^^ 

(if (not (ze'-o-f ixnum (sg-ncntrappabi h ty tcurrent-stack-group-status-bi ts) ) ) 
(parallel (halt error-tn-error-handier) (jump error-trap)) 
;: Ftxup the stack first, since we need to push some stuff 
(cal l-and-return-to restore-stack-pointer error-trap-1) ) ) ) 

(defucode error-trap-no-restore-stack 
(parallel (trap-save) 

(lisp (enter-error-handler)) ^^^ 

(if (not (zero-fixnum (sg-nontrappabi I i ty Xcurrent-stack-group-status-bi ts) ) ) 
(parallel (halt error- in-error-handler) (jump error-trap)) 
(goto error-trap-1)))) 

;Error trap from block read, VHA advanced one or two words 
(defucode-at-loc error-trap-vma-up-1 1CC14 

(parallel (trap-save) .,,,» 

(assign vma (- vma (b-constant 1)))) 
(parallel ( I isp (enter-error-handter) ) ... ^ ... . . w-* ^^^ 
(if (not (zero-fixnum (sg-nontrappabi 1 i ty tcurrent-stack-group-status-bi ts) ) ) 
(parallel (halt er: cr-in-error-handler) (jump error-trap)) 
;; Fixup the stack first, since we need to push some stuff 
(cal 1-and-return-to restore-stack-potnter error-trap-1) )) ) 

£defucods-at-loc error-trap-vma-up-2 20324 
{paral lei (trap-save) 

(assign vma (- vma (b-conctant 2)))) 

(paral lei ( i i sp (enter-err or -handler) ) . , , . 

(if (not (zerc-ftxnuffi (sa-nontrappabi I i ty •Zcurrent-stack-group-status-bi ts) ) ) 

(parallel (halt error-in-error-handlcr) (jump error-trap)) 

;; Fixup the stack first, since we need to push some stuff 

(cal l-and-return-to restore-stack-pointer error-trap-1) )) ) 

(defucode error-trap-1 

;; If tn error occurs, halt . , , ,*i 

(assion (sg-halt-on-error Xcurrent-stack-group-status-bi ts) (b-constant D) 

;; Puch the address of the microinstruction that signalled the error 

(assign b-temp (logand (pcp-control-stack) (b-constant 37777))) 

(puEhval (set-type b-temp dtp-fix)) 

(pushval (set-tupe vma dtp- locat i ve) ) 

;; Hake the pc point such as to retry the failed instruction. The error handler is 

;; likely as not aoing to mess with our state anyway. 

;; The ctack was already restored above. 

(take-pre-trap signal-error preserve-stack)) 
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;H*re if IFU needs help fetching instructions 
{defucode-at-loc i fu-c-mpty-trap lACCo 
(set-PC pc3 ) 

;This I see! is known b'j FACE-rAULT. A fault here prevents backing up the PC, 

(machine-ver 5 ion-case ( (tmc) 
(defucode i fu-etnpty-trap-l 

(start-memory reao tjlocK instruction-fetch) 

(start-memory read tJ/ock instruction-fetch) lActivell) 

(nop) ;Data(l). Active (2) 

(next- instruct ion))) jOecode (i) ,Uat3 (2) 

(otherwi se nil)) 

F:>1mach>ucode>SYM.LISP.7 

;;• -«- ttode;LISP; Packaoerflicro: Base: S; Lowercasei T -*- 
;;; (c) Copyright 19S2. Symbolics, Inc. 

; Microcode for operations on syr:bo!s 

in 

(declare (ccnd ((not (status feature Icucode)) 
(load 'udcls)))) 

(definst sunievai no-onerand 

(parallel (chJcK-data-type top-of-stack-a dtp-symbol dtn-ni U 
(acGign vma (+ top-of-stack-a (b-constant 1))) 
( jurp"refercnce-symbol-of f sc't) )) 

Idefinst fsuTreval no-operond 

(parallel' tcheck-data- tyre* top-of-stack-a dtp-sijmbol dtp-nil) 
(assign vrr,a (+ top-of-sisck-a (b-constant 2))) 
(jump reference-syn;bol-of f set) ) ) 

(defucode reference-surjbol-of f set 
(start-memory rca:i) " 

(nop) ;ti»e fcr the csRory 

(parallel (transport data) 

(neutop merory-dato) 
(next- instruct ion) ) ) 



(definst vaiue-cei i-f ocat ion no-opcrarsti 

(parallel (check-data-type top-of-stack-a dtp-symbol) 

(ncutcp (set-type (+ top-of-stack-a (o-constant 1)) 

dtp-toc3tf vcH 
(next-instruct'^on)) ) 

(definst function-cel l-location no-operand 
(parallel (check-oata-type tcp-of-stack-a dtp-suir,bol ) 

(neutcb (£st-type (+ top-OT-stack-a (b-cons^tant 2)) 

dtp- locative)) 
(next-instruct Icn) ) ) 

(definst prcperty-ce! l-lccat ion no-operand 

(parallel (check-data-tupe top-of-stccK-a dtp-symbol dtp-nil) 
(netJtop (set-type (+ top-of-stacK-a (b-constant 3)) 

dtp-locative) ) 
(next-instruct ion) ) ) 

(definst package-cef l-lccat icn no-opersnd 

(pcrallel (check-data-tyoe tcp-of-stack-a dtp-syr.bol dtp-nil) 
(newtcp (set-type i+ top-of-stack-a (b-constant ^)) 

dtp-locative) ) 
(next-instruct ion) ) ) 

(definst boundp no-ooerand 

(parallel (check-data-type top-of-stack-a dtp-symbol dto-ntl) 
(assign vtr,a (+ top-of-stack-a (b-consiant li)) 
(jump check-boundp) ) ) 

(definst fboundp no-operand 

(parallel (check-data-type top-of-stack-a dtp-symbol dto-nil) 
(assign vma (+ top-of-stack-a (b-constant 2) J) 
(jump check-boundp))) 

(defucode check-boundp 
(start-memory read) 

(ricp) %u^\X for meir.ory cycle 

(parallel (tranccort ur i te> :Tnis minht not be the ricjht kind of transport 

(if (ciata-type? meTtjru-data dtp-null I 
(para/ lei (neutop" quo tc-n i I ) 

(next-instruct i on) ) 
(parallel (neutop quote-t) 

(next-instruct ion) ) ) ) ) 
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(definst get-pnan.e no-op*rand .,. 

(paraiie! (chcck-data-tuDG top-of-stccv-.-a dtp-syrcsol dtp-nil) 

(assicn vma top-of-stack) 3 
(start-memory read) 

(r.op) ;w3it for memory cycle 

Iparallel (transpDrt header) 

(neutop "(set-type memcry-data dtp-array)) 

(next- instruct ion) ) ) 

(definst set no-cpfcran-:! 

(parallel (chcck-data-tupe next-on-stacK dtp-syntbo! ) 

- {ass.nn vrr.a (1+ nsxt-on-3tocK) ) ) 
(parallel (start-meT.ory rerid) ;read the value cell pointer 
(assif^n b-ter::p tcp-cf-st3Ck) 

(decrcTent-stack-pointer) ) ;pop o^f the valup 
(fof -effect (pcr.va!)) ;and the symbol pointer 

(parallel (tronrport uTite) :rotlcu any forusrding pointer 

(assign a-tenp tHerge new data uith old cdr code 

(»epge-cdr b-tenp meflory-data) ) ) 
(parallel (store-contents a-temp) ;Nou write back the neu car 
(next- instruct ion) ) ) 
;;; -»- f1ode:L 1 8p; Packanernicro; Base:8; Louerc3se:yes -«- 
:;: (c) Copyright 13S2, Symbol ic3» Inc. 

;Subpri«i tives 

;Get d«f»icro and alt his hosts 

(declare (cond ((not (status feature Ifflucode)) 
(load 'udcts))) 
(»expr gct-to-abus get-to-bbus) ) ; in UU 

;Hardw3re definitions (these wight belong in UU, however they 
; are not used by any files other than this one.) 

(defmicro cdr-field (opnd 4opt tonal background) 
•(parallel , (get-to-abus opnrt) 

(Idb ybus-crocks-l ,2 ,14. .background))) 

(defmicro high-type-field (opnd ^optional background) 
'(parallel , (aet-to-abus opnd) 

(Idb gbus-crocks-i ,2 ,12. .background))) 

;This gets the high 4 bits of the tag. The low 4 have to be LDBed separately 
(def»icro high-t?g-f ield (opnd fioptionsl background) 
'(parallel , (get-to-abus opnd) 

(Idb ybus-crocks-l .4 ♦12. .background))) 

(defmicro lou-tao-f ield (opnd ^optional background) 
MIdb ,opnd 4 28. .background)) 

(defmicro pointer-field (opnd ioptional background) 
*(ldb .opna 23. .background)) 

(defmicro set-lou-tag-f icld (opnd background) 

(■ake-mtcrodata 'obus 

(paralyze (qet-to-obus32 opnd) 

'toicro instruct ion force-obus<31-28> .background 
magic .background)))) 

(defmicro dpb-tag-f ie id (tag opnd) 
* (parallel , (get-to-bbus tag) 

(dpb .tag 4 28. ,opnd) 

(microinstruction force-obu3<35-34> bbus<7-G> 

force-obus<33-32> bbus<5-4>))) 

(defmicro dpb-tag-f ield-high-onty (tag opnd) 
•(parallel .(get-to-bbus tag) 
tcpnd 
(microinstruction force-obus<35-34> bbus<7-6> 

force-obus<33-32> bbus<5-4>))) 

(defmicro dpb-cdr-f letd (cdr opnd) 
(if (and (not (aton cd^)) 

(eq (car cdr) ' Idb) 
(equal (cdar cdr) ' (2 6))) 
(setq cdr (cadr cdr)) 

(retch "'wS not alioned for dpbing into cdr field, kludge, kludge" cdr)) 
•(parallel , (get-to-bbGs cdr) 
,cpnd 
(microinstruction force-obus<35-3A> bbus<7-G>))) 

(defmicro dpb-type-f teld (type opnd) 
•(pcrallct , (get-to-bbus type) 

(dpb , type 4 28. ,opnd) 

(microinstruction f orce-obus<33-32> bbus<5-4>))) 



4,887,235 
_271 272 

;Fteld extraction subpp iml t i vcs 



(p3rai lei 

;Get S-bit type field, rotated right 4 bits in a 32-btt word 
(assign b-temp (hich-tyoe-f icid top-of-stock-a top-of-stacK-a) ) 
(if (data-ttipe? top-of-stack-a dtp-fix cilp-flcatJ 

(paraiiwi (neutop (set-type (dpto b-teftp 2 4 8) dtp-fix)) 
(next- instruct ten) ) 

jThis bizarre LD3 rotates left 4 then «asks to B tou bits 
(parallel (neutop (set-type (strange- I db b-temp B 34) dtp-fix)) 
(next- instruct ion)) ) )) 

(definstl Tlpo inter (no-operand needs-stBv-k.) 

(neutop (set-type (pointer-field top-of-stacK) dtp-fix)}) 

(definstl Xfixnum (no-operand needs-stack) 
(check-data-type top-of-stacK-a dtp-float) 
(neutop (set-type top-of-stack dtp-fix))) 

(definstl tf lonum (no-operand needs-stack) 
(check-data-type top-of-stack-a dtp-fix) 
(neutop (set-type top-of-stack dtp-float))) 

;''Pointer*' construction 

(definstl Imake-pointer-immed unsioned- immediate-operand 

(neutop (dpb-type-f ieid macro-unsigned-inmediate top-of-stack-a) )) 

(definst Xfflake-pointer-itnmed-of fset unsigned- immediate-operand 
(popZpush (set-type (+ next-on-stack top-of-stack) dtp-fix)) 
(parallel (neutop (dpb-type-f i eld cacro-unsigned-iiimedl a to top-of-stack-a)) 
(next- instruct ion)) ) 

;2 cycles because it takes its damned arauments in the urong order 
;Bfts <33:32> can only be DPB*ed from the B side (perhaps they could 
;come from the Y bus instead, but that uoutd probably break other things). 
(definst tt;::ake-po inter no-operand 
(para I le! 

(check-data-type next-on-stack dtp-fix) 

(assign b-tetrp next-on-stack) 

(assign next-on-stack top-of-stack) 

(decrement-stack-pointer)) ;Can't use pop2push in next 
(pcral le I 

(newtcp (dpb-type-f ield b-temp top-of-stack-a) ) 

(next- instruct! en) ) ) 

;2 cycles in order to get a fixnum resuU of the correct sign 
(deftnst Apointer-di f ference (no-operand needs-stack) 
(para I lei 

(ass ion b-temp (- next-on-stack top-of-stack)) 
(if (Tesser-pointer next-on-stack top-of-stack) 
(paral le! 

(pop2push (set-type (set-tou-tag-f ield b-temp 17) dtp-fix)) 
(next-instruction) ) 
(paral lei 

(pop2push (set-type (set-lou-tag-f ield b-temp 8) dtp-fix)) 
(next-instruction))))) 

F:>1mach>ucode>subprim. lisp. 321 

tAccessing tiemory colls indirect through pointers 

(defucode memread ;Call uith pointer in VnA 

(star t -memory read) ;Return uith data in •emory-data 

(return) ) 

(defucode memread-ur i te 
(start-memory read write) 
(return) ) 

(definst Xp- 1 db- i fpmed (18-bi t-i«medic?te-opcrand needs-stack) 
(memread top-of-stack) 

(parallel (neutop (set-tuce Odb «emory-data uacro occro) dtp-fix)) 
(next-instruct'on) ) ) 

;This is 5 cycles uhereas Xp-cdr-codc couJd bo done in 4. Saves opcodes... 

(definst Xp-tag-ldb-isifred (unsigned-ioi-ediate-operand needs-stack) 
(memread top-of-stack) 

;Get 6-bit type field, rotated right 4 bits in a 32-bit word 
(assign b-tenp- (high-tag-field memory-data memory-data)) 
;Here ue assume tnat the mask generator does the right thing 
;80 that we can LDB out of this byte uhich straddles a uord boundary 
;The macro i nstruct ion' s R in the immediate operand is hacked appropriatelg. 
(parallel (neutop (set-type (Idb b-tepp macro macro) dtp-fix)} 
(next- instruct ion))) 
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(definst tp-dpb-'iKmecJ {23-&i t- Jmaerfiate-opcrand needs-stack) 
(assign vma top-of-stack) 
(parallel 

(start-wentopy read write) 

(assign b-temp nsxt-cn-stack) 

(decpement-stack-pointer) ) 
(fop-effcct (popvai)) 
(para I lei ^ ^ m 

(assign xemopy-data (dpb b-temp fiacro itacro neaory-data) ) 

(stapt-ttemopy upite) 

(next- instruct ion) ) ) 

;3 cucles. Ip-store-cdp-code could fee done in A cycles. Saves oDCOdes... 
(definst ip-taQ-dpb-immed (unsigned- immediate-operand needs-stack) 
{a=.sitjn vaa top-of-stack) 
(parallel 

(start-memory read write) 

(assian b-temp next-on-stack) 

(decreaent-stack-pointer)) 
(for-effect (popvai)) 

(assign a-tcmp-2 r.eaory-data) :for tenporaru eesory control 
(ascign b-terRp-2 (hian-tac-f tel d a-tcrr.p-2 a-tefBp-2)} . « .. 

(assign a-temp (strance-ldb b-temp-2 & 34)) jRotate left 4, take low 8 bits 
; Hcu ue have the tag"field r inht- just i f ied, do the user s DPS 
(assign b-tensp (dpb b-temp nacro macro a- temp)) 
: Re-assemble the memory word and store it back- Not easy 
; because everyone in sioht is trying to use U AHUA field. 
; Have to do the low & high tag fields separately, 
(assign b-temp-2 (dpb b-temp 4 2S. a-temp-2)) 
(assign a-tetrsp b-tcn:p-2) 
(parallel . . . . »x 

(assign memory-data (dpb-tag-f icid-high-only b-temp a-temp)) 

(start-memory write) 

(next-instruction) ) ) 

; Leaves T05 wrong 

(definst Vp-store-contents (no-operand smashes-stack) 

(parallel (memread next-on-stack) ; — request write access? 

(decrement- stack-pointer)? 
(assign a-temp (merge-cdr top-of-stBck ncmory-data)) 
(parallel (stope-contents a-temp) 

(decpcrr.cn t-stacK-co I ntep ) 
(next-instpuct ionj) ) 

;Leaves TOS wrong 

(definst *Xp-store-cdr-and-contents (no-opff"and smashes-stack) 
(parallel (assirn vma (amen (stack-pointer -2))) ;Pointer 

(docrement-stacK-potnt:;r)) , ^ , *, * * 

(parallel (ajjsinn b-terp (rotate (amcm (stack-pointer 1)) 6)) ;Cdr 

(decremcnt-ctack-pointer)) . * , » » - 

(assiqn a-temp (dpb-cdr-f i c 1 d (Idb b-temp 2 6) (araem (stack-pointer 1)))) ;»crge Contents 
(parallel (store-contents a-temp) 

(decrement-ctack-po i ntep) 

(next- instruct ion) ) ) 

;leove5 TOS wpong 

(definst *p-store-tari-and-pointer (no-operand needs-stack smashes-stack) 
; a-teir.p gets poi nler-f i el d, b-tcmp gets tag-field 
(papal lei (assign a-ter.p top-of-stacK) 

- (assign b-tero next-on-stack)) 
; a-temp nets the wopd to be stoped 
(parallel (assign a-tetro (dph-tag-f ield b-temp a-temp)) 

(decrement-stack-pointer) ) 
; vir.a gets address to store it into 
(parallel (assign vma next-on-stack) 
Cdecrement-ttack-pointer) ) 
; store i t 
(para I lei 

(start-Memory write) 
(assign memory-data a-temp) 
(decrement-stack-pointer) 
(next- instruct ion) ) ) 

(definst Xp-contents-as-locat ive (no-oparand necds-stscK) 
(memread top-of-stack) 

(parallel (newtop (set-tupe memory-data dtp-locative)) 
(next- instruction) ) ) 

;Args are pointer and offset. Follow any structure forwarding in the 

; header pointed to by the pointer, then return the result plus the 

;off6et, as a locative. Offset isn't type checked since not convenient. 

;Thi3 used to do a data-type check* fcrcing the base wcrd to really be a header. 

;lhat turned out to be too inconvenient, and the A machine doesn't do it, 

; so I f lushed i t. 

(definst Xp-structure-of f set no-operand 

(parallel (memread next-on-stack) 

(assign b-vcia next-on-stack)) 

(transport header-or-data) 

(parallel (pop2pu5h (set-tyr? (+ b-vma top-of-stack-a) dtp-locat ive) ) 
(nex-t- instruction) ) ) 



4,887,235 
275 276 

(definst foMou-struclure-fcruardinq no-operand 
(paral lei (memread top-of-stsck-a) 

{assign b-vBia top-of-stacK-a) ) 
(transport headir-or-data) 
(parallel (neutop (pointer-field b-vma top-of-stack-a) ) 

(next- instruct ion) ) i 

(definst fol low-eel I-foruarding no-operand 

(parallel (check-arg-type 8 next-on-stack dtp-lccat r ve) 
(assign vma next-on-stark) 
(assign b-vca ncxt-on-stack) ) 
(start-memory read) 

(if (data-type? top-of-stack-a dtp-nil) 
(parallel (trancport bind-urite) 

(popZpush (set-type b-vxa dtp-locat ive) ) 
(next- instruct ion) ) 
(parallel (transport write) 

(pcp2pu£h (set-tyoe b-vna dtp-locat ive) ) 
(next- instruct ion) ) ) ) 

;5top the machine. 

;For macrocode breakpomts, this must halt before incrementing the PC. Hence 
: SEQUENTIAL rather than PARALLEL, 
(dsfinst Vnalt no-operand 
(sequential (halt 51halt) 

(next-instruction))) ;Allow cianual proceed 

;Re2d the microsecond clock 

(aefinst ^microsecond-clock no-operand 

(assion b-tenip (set-type (read-Ibus-dev 35 C) dtp-fix)) 

(parallel (puchva! b-temp) 

(next- instruct ion))) 
;;; Bulk memory initialization 

; stack-offset -4 -3 -2 -1 

; (Xblock-store-cdr-and-contcnts address count cdr contents increment) 

; (Sblock-store-tag-and-pointer address count tag pointer increment) 
;a-temp holds word to be stored 

(definst tblock-store-cdr-and-contents (no-operand needs-stack smashes-stack) 
tassinn b-ter.ip idpb (amem (stack-pointer -2)) 2 6 8)) ;A!ign ctr code 
(parallel ^ ;Store-dot3 

(assign a-temp (dpb-cdr-f leld (Idb b-temp 2 G) (amem (stack-pointer -1)))) 
(jurap Dlock-store-start) ) ) 

(definst Xblock-store-tag-and-pointer (no-cperand needs-stack smashes-stack) 
(assign b-temp (amem (stack-pointer -2))) ;T3g field 
(assian a-temp (anem (stack-pointer -1))) tPointer field 
(parallel :Store-data 

(assign a-temp (dpb-tag-f ield b-temp a-temp)) 

(jump block-store-start))) 

(defucode b I ock-store-start 

(assiqn a-temp (merge-hi gh-tag (- a-temp top-of-stack) a-teop) ) ;Pre-decrcment store-data 
(parallel assrgn vma (amem (stack-pointer -4))) ;First address in block 

(ju.-np block-store-fast-loop))) 

; Increment data, store result in memory and back in data. 
;]nG increment must not cross a GC spcce boundary since the GC-nap lookun 
;rs on the unmcremented data. The address storing into must not ba in Amen, 
(defmicro store-contents-wi th-increnent (data increment &rest options) 
'(paral tel 

(assign .data (merge-hfgh-tag (-t^ ,data .increment) ,data)) 

(store-contents obus obus-as-good-as-abus no-araem • , opt ions))) 

(defucode block-store-slow-loop 
:; Test count 
(if (minus-or-rero-f ixnum (amem (stack-pointer -3))) 

(parallel (assign stack-pointer (- stack-pointer (b-constant 5))) 

(next-instruct ion) ) 
(droD-thrcugh) ) 
(stcre-contents-wi th-increment a-temp top-of-stack block) 
;;Upd3te arguments 

(assign (amen (stack-pointer -3)) (set-type (1- (amem (stack-pointer -3))) dtp-fix)) 
(assign (amem (stack-pointer -4)) 

(set-type (1+ (amem (stack-pointer -4))) dtp-locative)) 
(parallel (assign (amem (stack-pointer -1)) 

(mcrge-hi gh-tag (+ (amem (stack-pointer -D) top-of-stack) 
(amem (stack-pointer -1)))) 
(jump block-store-slow-locp) ) ) 

(defucode block-stcre-fast-loop 

(if ( lesser -f ixnum (amem (stack-pointer -3)) (b-constant 8)) 

(goto block-stpre-slow-loop) jAlnost done, go slow 

(drop-thrcugh)) _ :Block-writ3 eight words 

(store-contents-wi th-increment a-temp top-of-stack block) 

(stcre-contents-wi th-increment a-temp top-of-stack block) 

(store-contents-ui th-increment a-temp top-of-ctack block) 

(store-contents-wi th-increment a-temp top-of-stack block) 

(store-contents-wt th-increrr<ent a-terp top-of-stack block) 
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(store-contents-ui th-incrcrr.ent a-terrp top-of-stack block) 
<5tcre-contents-wi th-increncnt a-ter,p top-of-stacK block) 
UtO'^e-contcnts-ui th-increr.ent a-ter.p top-of-atack biock) 
(assign (amem (stack-pointer -3)) ;Nou checkpoint into arguments 

(set-tut?e (- (amefT (stack-pointer -3)) (b-constant 8)) ritp-fix)) 
(assign (amem ^stack-pointer -4)) 

(set-type (+ (anem (stack-pointer -4)) (b-constant 8)) dtp-locat iva) ) 
(parallel (assign (amem (stack-pointer -D) 

Imerge-high-tag (+ (amem (stack-pointer -1)) 

it^iti top-of-stack 23. 3 0)) :i.e. multiply by 8 
(afre?!i (stack-pointer -1)))) 
(jun-.p biock-store-fast-locp) ) ) 

Read an unsynchronized device register . This relies on the fact that the 
emulator task has its own Hu register(s), which can be used as a synchrcnizer, 
— -Take out the forced dtp-fix when we get rid of the rev-1 I/O board, which 

doesn't atw3'js set the data type when reading registers. 

(definst 'i^uncynchronized-dev ice-read no-cperand 
(memread tcp-of-stack-a) 

(nop) :Delay 1 cycle before tcoking at register 

(parallel (declare-memory-t iming data-cycle) ?Fake cut error checking in wicrocode compiler 
(newtop (set-type memory-data dtp-fix)) 
(ncx i- instruction) ) ) 

;Thi2 interlocks against tasks, but cannot interlock against the FEP 

;Uniike the A-rachTne, pdsring enables interlocking to work even if the 

;old value is transported. Interlocking does not work in the presence 

;cf forucrding-po inters, however. 

(definst store-conditional (no-operand needs-stack) 
(parai lel 

icheCN-arg-tupe (amen (stack-pointer -2)) dtp- locat i ve) 

(RieTirend-wr i t2 (anem (stack-pointer -2)))) ;Fir3t ensure write access 

(parallel ;Then read it again, interlocked 

(start-memory read) ;This won't start if task ewitch iirpcnding 

(di sable-tasking) ) jPrevent task switch before data cycle 

(paral let 

(assign b-tenp next-on-stack) tOestred ofd contents 

(assign a-temp top-of-stack) jNew contents 

(deer cment-stack-po inter) 

(disable-tasking)) ;Prevent task switch before store started 

(para I iel 
(transport) 

(acsign b-temp memory-data) 
(if (equal- typcd-po inter memory-data b-tcmp) 

(sequential ; Succeed 

(store-contents a-temp (cdr b-temp)) 
(parat lel 

{popZpush quote- t) 
(next- instruct ion) ) ) 
(paraNol ;Fai I 

(pcp2push quote-nil) 
(next- instruct ion) ) ) ) ) 

F:>lmach>ucode>$ tack-buffer. lisp. 67 

;;; -»- node: Lisp; Fackaaerfli cro: Base: 8; Lowercase: yes -*- 
;;; (c) Copyright 13S2, Symbolics, Inc. 

• hicrocode for maintenance of the stack buffer 

m 

(declare (cond ((not (status feature Imuccda)) 

(load 'udcis)))) 

(declare (special *page-sire*} ) ;in SITi 

;Dump a pSf^e out of the stack 

;Checks for stack overflew, unmaps the page from the stack buffer, and pushes 

;state into the stack, setting stack-ioad-atarted, 

; first address to dunp 

; last address to dwr.p +1 

;This stack state allows the instruction to be pclsred during the dumping process 

;After the dumping is complete, the sta;k-buf fer-underf leu bits are reset to 

;reflect the new bottom trane in the ct3ck, the state is removed, stack- tor;d-started 

;is cleared, the new page is mapped into A-me.nory, and the stack-buffer address and 

; I ini t are adjusted. 

;nust not attempt to stack-r:'oup-3ui tch while stack-load-started flag is set! 

(definst stack-durp no-operand 

(if (not (bit stack-load-started)) 
(sequential 

(errcr-if (nreatGr-or-equa) -po inter stack-limit lcontrol-stack-1 imi t) 
stack-ovcrf tow) 

(puQhval (set-type *ctack-buf fcr-low dtp-fix)) 
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;; Te.Tpcrary kiuc^ge necessary because stacks are arrays, uhich they 

;; shouldn't be, and hence arc* not pane-al 'fned 

(if ()esser-pc;nt=r tcn-of-stacK IcontroT-stack-lcw) 
(newtop (eet-type ^controi-stack-lou dtp-fix)) 
(drop-throuahl J 
(pusnval (set-type (+ listacK-buffcr-low (b-constant »p2ge-si2e*)) dtp-fix)) 
(parallel (assign b-terr.p Xstack-buf fer-lou) :Unm3p old page 
(assign Istack-buf fer- low top-of-9tack) 
(cai t of ear-b-temp-paae-fpon-map-cache) ) 
(parallel (assign stack-load-started (b-constant 1)) 

(clecr-stack-adjustnent))) ;Keep this stark state if pcisr 
(drop-throurjh) ) 
(parallel (assign xbas next-on-stack) 
(assign vma next-on-stack) 
(call stacK-cfurp-f oop) ) 
{parallel (asslg-i vna (-^ -stack-buffer- low (b-constant (* 3 ^pane-size*) ) ) ) 

(call msp-p2ne-to-stack-buf fer)) -flap neu fourth page 
(paral (el (decrernent-stack-pointer) 

(pssicin stack- loac^-started (b-constant 8))) 
(parallel (for-eUcct (pcpvaD) 

( jump adjust-frane-buf fer-underf lou-bi ts) ) ) 

(defucode stack-durp- Iccp 

(if iequal-pointcr next-cn-stack top-of-stack) 
(goto sfit-stock-buf fer-l imi t) 

;;Dump 1 word. For real menory control, can change this to do 8 i»crds in a block 
;;!rjrite. then advance xbas and next-on-stack by t instead of 1. flust be careful 
;;not to advance state until after guaranteed not to page-fault. 
(sequential 

(store-contents (amem (xbas C) ) ) 

(parallel (assinn next-on-stack (1+ next-on-stack)) 
(assi , T xbas obus) 
(assign vno obus) 
(jump stack-dump-loop) ) ))) 

(defucode cet-stack-buf fer- I inii t 
;: Now decide hnu nanj pages of stack buffer to use. Normally 4, unless ue are 
:; close to the end or \r\e stack. 

;; naxirum frame sire is ^i^Z here. Decrease this to 1C3 later when corpilcr detects 
;; large frair.es and Generates explicit checking instructions 

(assign stack-limit (sct-tybe (+ tstack-buf f er-lou (b-constant (- 2633 433 1))) dtp-fix)) 
((f (greater-pointer stack- t i r.i i t Xcontro f-stack- I iml t) 
(assign stack-limit ^control-stack-t imi t) 



(drop-throuQl-p) ) 
;; Bet *stack-buf fer-l imi t tc 



- to highest virtual address in stack buffer, 
ihts 1+ is because tf.c- rraxinum frame size is 483, if it was smaller it could be deleted. 
(assign '>;ctack-buf fer-l imit (1+ stack-limit)) 
(parai le I 

(assign Istack-buf f er- I in) t 

tset-type ( logior tSstack-buf fer-I imi t (b-constant (1- *page-si2e*) ) ) dtp-fix)) 
(return) )) r- a k 

;Stack-buffer loadino. At this point the current frame is not evm in 
; the stack buffer. 

;Find the previous frame and decide how many pages need to bo loaded into the 

:stack buffer. Ue need all of the current frane plus the part of ita caller 

:that contains our arguments. Unmap that rany pages from the high end, ccpg 

;the pages from ir.ain memory into the stack buffer, then map those addre^-^^s 

;mto A-memory. Aajust the frame-buffer-underflow bits in the newlu-loaied 

; frames. 

;The following state is kept in the stack across pclsrings, protected by stack-load-started. 

; First address to be loaded 

; Next address to be Eoaded 

; Last address to be loaded-fl 

(definst stacK-lcad no-operand 

(if (not (bit stack-load-started)) 
(sequential 

;; Read frame-previous-top from memory 
(memread (- frame-pointer (b-constant 4))) 

(assign 3-tcmp (1+ momcry-dsto) ) ;Lowest address in frame 
;; Kush state (new *stsck-buffer-Iow, range of memory to be loaded) 
pushva (set-type (togand a-temp (b-constant (- »page-si2e»)) ) dtp-fix)) 
Ipushval top-of-stack) 

;; Temporary kludge necessary because stacks are arrays, which theu 

•s — 7 shouldn t be, and hence ere not page-aligned 
(tf lesser-pointer top-of-stack tcontroT-stack-low) 
newtop (set-tiipc icontrol--tack-iow dtp-fix)) 
(drop-thrcugh) 1 
(pushvai (set-type %3tack-buf fer-icw dtp-fix)) 
(parallel (assign stack-load-started (b-constant D) 

(clear-stack-adjustment))) -Keep this stack state if pclsr 
lorop-tnrcuah) ) 
(parallel (assign xbas next-on-stack) 

(call stack-load-loop)) 
(parallel (assign stack-load-started (b-constant 8)) 

(cal i st3ck-fo3ri-setup-map)) 
'P'ir=?llel (for-effect (popvaD) 

(jump ad jus t-fraase-buffer-under flow-bits))) 



4,887,235 
281 282 

— J'.aAe d tempcrary debugging test before entering the real stack- load- loop 

The original reason for this has been found* but it probably doesn't hurt 

to leave the test around for a while. If the frame-prevtous-top of a frame 

ever gets clobbered, this uii II cauE3 the inachine to halt before the stack 

. — buffer contents get totally trashed, 
(defucoda stack-load-Toop 

(assign b-temp (- top-of-stack next-on-stack) ) 
(parallel (trap-if (greater-pointer b-temp (a-constant 1^00)) 
(halt stack-buf fer-fucked-up)) 
(jump stack-load-loop-D) ) 

(defucode stack- toad-Ioop-l 

(if (equal-pointer next-on-stack top-of-stack) 

(parallel (assign stack-pointer (- stack-pointer (b-constant 2))) 

(jun:p fixup-tos)) 
;;Lcad 1 word. For real memory control, can chancie this to do 8 words in a block 
j;reaa, then advance xbas and next-on-stack by 8 instead of 1. Must be careful 
;;not to advance state until after guaranteed not to page-fauit. 
(sequent iai 

(assign vma next-on-stack) 

(start-memory read) 

(para! lei (assign next-on-stack (1+ next-on-stack)) 

(assign xbas obus)) 
(paral let (transport) 

(assign (anem (xbas -1)) fieoory-data) 
(jump stack-load-ioop-D) 1 ) } 

;Loop moving tstack-buf fer-lou down a page and mapping that page until all the pages 

;that were loaded have been processed 

;Also as we go, unmap the paoes that used to map into the tame Amem page (from the 

;other end of the stack buffer) 

(defucode stack-load-setup-fiiap 

(assian !tstack-buf f er-low (- tstack-buf fer- low (b-constant ^page-si-ze*) ) ) 
(parallel (assign vma (+ Xstack-buf fer-Iow (b-constant (« 4 «page-si2C*))) ) 

(call clear-page-from-nap-cache) ) 
(if (equal-pointer Xstack-buf fer-low top-of-stack) 
(parallel (assign vma 'tstack-buf fer-low) 

(cal l-and-return-to m.^p-pane-to-stack-buf fer set-stack-buf fer-l imt t) ) 
(parallel (assign vna Xstack-buf fcr-Tow) 

(cal l-snd-return-to map-page-to-stack-buffer ctack- I oad-se tup-map) ) ) ) 

Adjust the frmme-buf fer-underf low-bi ts of alt frames in the stack buffer 
ao that the lowest comoleteiy-in frame has a 1 and thie rest have a C. 

Possibilities for bumming this to avoid having to set bits to 

zero (saves one cycle per frame). Remember the irsxe uhosa bit 

is set, and before dumping clear it. Thus when loading all the 

bits will be loaded as zero, and when dumping ue need not clear 

— any bits since they are already clear. 

Frame field acccssors relative to xbas rather than fp 

(defatomicro xframe-mi sc-data 
(acem (xbas -2)) J 

(defatomicro xframe-prev i ous-top 
(amea (xbas -4)}} 

(defatomicro xframe-prev ious-frame 
(amea (xoas -5) ) ) 

(defatomic-byte-f ield xframe-buf fer-unrierf Icw-bi t frame-buffer-underflow-bit 
xfrarr-e-mi sc-data) 

(defatomic-byte-f ield xframe-bottom-bi t frame-bottom-bit 
xframe-mi sc-data) 

;The code 

(defucode ad iust-frame-buf fer-underf low-bi ts 

(assign b-temp (+ Xstack-buf fer-low (b-constant 5))) ;Frame underhang 
(parallel (assign xbas frame-pointer) 
(assign b-tesp-S obus) 
( jump adjust-trame-buf fer-underf I ow-b i ts-1 ) ) ) 

(defucode adjust-frame-buf fer-underf I oM-bi ts-1 

(if (lesser-pointer xframe-prev ious-frame b-temp) xPrt^^ frame not in 

(sequent iaI 

(assiqn b-temp (1- tstack-buf fer-low) ) 

(if (lesser -pointer xframe-previous-top b-temp) jThis frame not all in 
(assign xbas b-temp-2) tso back up one frame 

(drop-through)) 
(paral let 

(assign xframe-buf fer-underf lou-bi t (b-constant 1)) 
(return))) 
(if (bit xframe-bottom-bi t) 

(return) ;Bottom of stack, alt frames in 

(sequent lat 

(assign xframe-buf fer-underf low-bi t (b-constant 0)) 
(ass i en b-teT.D-2 b-temp.3) 

(parallel (assign xbas xframe-previous-frame) 
(assign b-temp-3 obus) 
(jump adjust-frame-ouffer-underf tow-bits-1)))))) 
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F:>lraach>ucode>sg,1isp.41 

;;; -»- ttode: L i sp; Packaqet Hicro; BaserS; Lowercaaeryes -»- 
;;; (c) Copyright 19£2, Syrcaclics, Inc. 

; Microcode for stack, groups 

;Get defaicro and all his hosts 
m ' 

(declare (cond ((not (status feature toucode)) 
(load 'udcls))n 

(reserve-scratchpad-ntPicry ?4AA 2450 337 343) 

(defareg a-stacK-grcup-iocK.) ;NIL norma I I y, else how far ue have gotten 

; in the process of suitching (see the code) 
(defareg a-stack-group-enter ing) ; stack-group in process of entering ° 
(defareg a-stack-group-ieaving) ; tracks for dsfcuaging only 
(defareg a-stack-gpoup-argument) ; Value being conveyed across SG suitch 
(detbreg b-binding-ooundary) ;Bcund3ry betuein swapped and unswapped binding stack 

(define-enumer a ted- value-const ants «sg-arg-statu9-codes*) 

This .instruction is called by the stack-group-sui tch pr initives, as welt as 
from an escape function used for sequence breaks and error trapa. 

Takes three arguments on the stack: 

Ihe value to be conveyed 

The stack qroup to switch to 

The new value for SG-STATUS-BIT5 of this stack aroup 
Normally the third argument is simply a new value for SG-ARG-STATUS. however 
if higher-order bits are on they get lORed in, allowed nonresumabi li ty bits to get set, 

Uill return with a value on the stack unless the new SG-ARG-STATUS is tSG-ARG-Nt>£, 
If the new 5G-ARG-STATUS is XSG-ARG-BREAk, then the first argument is the PC to 
be used when this SG is resumed, instead of the current FC, and no value is 
to be returned in the stack either. 

Also ue have (associated with the stack group lock) an indication of how far 
we have progressed, so that thts instruction can be pclsred. 

Proceed as follows: 

If the stack-group lock is already locked, re-enter at appropriate point 

Error if target stack group not resumable 

Shuffle the stack to reflect how we want it to be upon return 

This means leave a slot for the value if necessary, then push the PC 
Lock the stack-group lock 
Dump the entire stack buffer 
Swap the special "-var i able bindings 

Dump the stack group state (including FP, SP) into main nemory 
Load the new stack croup state from main memory into A-memory, FP, SP 
Load the stack buffer (for the current frame) 
Stash the ar9ument in the stack if wanted 
Unswap the bindings 
Unlock the stack-group lock 
Popj 

(definst !llstack-group-swi tch (no-operand needs-stack) 
;; Check for retrying after pc t sr 
(paral !el 

(dispatch-after-next (idb a-stack-group-lock 3 0) 

((3) (goto cent inue-sg-stack-buf fer-dump) ) 
((1) (goto cont inue-sg-swap-out-bindings) ) 
((2) (goto sg-duffD-9tate) ) 
((3) (goto sg-load-state)) 
((A) (goto cont inue-sg-stacK-buffer-(oad)) 
((5) (goto continue-sg-swap-in-bindings) ) ) 
(if (not (data-tuDe? a-s tack-group- lock dtp-nil)) 
(take-di spnlch) 

(assign a-stack-group-!eaving tcurrent-stack-group) ) ) 
;; Check resumability of new stack group 
(paral lei (check-data-type next-on-stack dtp-array) 

(memread (+ next-on-stack (b-constant (field-word-offset *8g-nonrcsumabi I i tu) ) ) ) ) 
(parallel (transport data) ^ 

(trap-i f (not (zero-f ixnum (sg-nonresumabi I i ty memory-data) )) 
(signal-error stack-group-not-resumaole) ) ) 
;; Process arguments and shuffle the stack appropriately 
(assign iso-arg-statuc ticurrent-stack-group-status-bi tcJ top-of-stack) 
(paral iel (assign Icurrent-stack-group-status-bi ts 

(set-type (logior *current-stack-group-8tatus-bi ts top-of-stack) dtp-fix)) 
(decrenent-s tack-pointer) ) 
(parallel (assign a-stack-group-enter ing top-of-stack-a) 

(decrement-stack-pointer) ) 
(assign a-stack-group-argument top-of-stack-a) 

(if (Tesser-or-equal-f ixnum-unsigned (sg-arg-status Xcurrent-stack-group-status-bi ts) 

Xcg-arg-break) 
(tf (equal-f ixnum (sg-arg-status Xcurrent-stack-group-status-bi ts) Xsg-arg-break) 
;; PC on stack, no value slot under it, pass self as argument 
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(ass inn a-stacK-aroup-srgur.ent ^current-stack-gpoup) 
;; Put PC on stacK, no value slot under it 
{neutop pc) ) 
;; Normal Cuec, put FC on stack with value slot under it 
(puchvat pc)) 
;; Prepare to durr.D the stack buffer 

(puchval (set-type Xstack-buf fcr- lou dtp-fix)) tFirst address to dump 
;; — Teinporary kludge necessary because stacks are arrays, which they 
:; — shouldn't be, and hence are not page-aligned 
(if (lesser-pointer too-of-stack tcontrol-stack-low) 
(newtcp (set-type Xcontroi-stack-tow dtp-fix)) 
(drcp-thpourjh) ) 
(puEhvai (set-tijpe stack-pointer dtp-fix)) :Last address to duop-fl 

(parallel (assifjn a-stack-group- 1 ock (set-type (a-constant 0) dtp-fix)) 
(clear-stack-adjustment) 
(jump sg-stack-Duffer-dump))) 

(defucode sg-stack-buf fcr-dump 

;; Unr.ari all of the stack buffer pages 
(assion b-temp Xstack-buf fer-low) 
(if (TessEr-pointer b-tcn:p :tstack-buf fcr-l imi t) 
(paral tel 

(assign tstack-buffer-low (+ Xstack-buf fer-low (b-constant «page-8ize*) ) ) 
(cai l-and-return-to clear-b-tcpip-page-from-map-cache sg-stack-buf fer-dump) ) 
(goto continue-sg-stack-buf fer-dua^.p))) 

(defucode continuc-sg-stack-buf fer-dumo 
(parallel (assign xoas ncxt-on-stack) 
(assign vma next-cn-stack) 
(cal I stack-dufflp-tocp)) 
;; fle«ove s tack-dump- 1 oop arguif.ents from the stack 
(assign stack-pointer (- stack-pointer (b-constant 2))) 

;; Tnere is now nothing mapped into the stack buffer, --^t tt to hinhest possible pointer 
(assign rstack-buffer-Tow (set-type (a-constant 1777777777) dtp-fix)) 
;; Prepare to swap the special-vor iapl c bindinqs 
(ass inn b-binding-boundary (1+ Xbindi ng-e tack-pointer) ) 
(parallel 

(assign a-stack-group-teck (set- tune (a-constant 1) dtp-fix)) 
( juap cont inue-sg-swap-out-bindingsJ ) ) 

(defucode cont inue-sg-swap-cut-bindings 

(if (equal-pointer b-binding-boundary tbinding-stack-low) 
;; Done whole binding stack 
(goto eg-duinp-state) 
(drop- through) ) 
;; Read the pointer to the bound location 
(■ear cad (1- b-binding-boundary) ) 
(parallel (transport) 

(assign b-temp memory-data)) 
;; Read the old contents cf the bound location, checking write access 
(»ecread-wr i te (- b-binding-boundary (a-constant 2))) 
(parallel (transport bind) 

(assign a-temp-2 memory-data)) 
;: Read the current contents of the bound location 
(vearead b-tcmp) 
(parallel (transport bind) 

(assign a-tenip «emory-dat3) 

(assign b-temp memcry-data) ) 
;; Urite the old contents there (preserve cdr code) 
(store-contents a-temp-2 (cdr b-temp)) 

;; Store current contents into binding stack (better not pclsr!) 
(parallel (assign vma (- b-binding-boundary (a-constant 2))) 

(assign b-binding-ftoundary (- b-binding-boundary (a-constant 2)))) 
(parallel (store-contents a-terp) 

( jump cont i nue-sg-swaJD-out-b i nd i ngs) ) ) 

(defucode so-dump-state 
;; Ouap FP, SP, and the A-rrem copy of the stack group state into memory 
;: If this pclsrs in the middle, tt can just start over from the beginning 
(assr9n a-stack-group-lock (set-type (a-constant 2) dtp-fix)) 

;; Write fP, SP m not-po inter mode to defeat the phantom stack gc that doesn't exist yet 
(assign vma (+ tcurrent-stack-group (b-constant (f ield-word-of f est ' sg-franje-pointer) ) ) ) 
(store-contents (set-type frame-pointer dtp-locative) block not-pointcr) 
(store-contents (set-type stack-pointer dtp-locative) block not-pointer) 
;; flake sure "active" ts cleared in the stored state 

(assign (sg-active-bi t Xcurrent-stack-group-status-bi ts) (b-constant 8)) 
(assign vma (+ Xcurrent-stack-group 

(b-constant (f ie Id-word-off set ' tg-binding-«tack-pointer) ) ) ) 
(stcre-ccntents Xbinding-stack-pointer block) 
(store-contents i'catch-btock-l t st block) 

(parallel (store-contents MCurrent-stack-group-status-bi ts block) 
(jump sg-load-state)) ) 

jflicro to simulate block reads. Also does transport. Get a word every 4 cycles. 
(defato»icro next-memcry-data 

(parallel (dec tare-memory- timing data-cycle) ; Coder better get it right... 

(transport aata) 

memory-data 

(call start-read-next))) 
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;Sut3Poutine for the above 
(defuccde start-read-next 

iparaMel taesicn v^a (1+ vma) ) 
( jurr.p'memread) ) ) 

(defucode so- load-state 

;; Load F.' , SP, and the A-mem copy of the stack group state from memory 
;; If this pcisrs in the niddle, it can just start over from the beginnino 
(parallel 

(assign a-stacR-group- lock (set-type (a-constant 3) dtp-fix)) 
(call sg-load-state-interna!)) 
;: Set up to lo:jd the stac«'. buffer. Lead from the beginning of the page 
;; that includes tne beginning of the current frame up to top of stack. 
;; Read frame-previous-tcp from memoru 
(assign vrra (- trame-poi nter (b-constant 4)}) 
(start-cerrory read) 

(acsion a-stack-grcup-lock (set-type (a-constant 4) dtp-fix)) 

(assign a-te-p (i^st-tupo (i+ memory-data) 0)) ;Lowest address In frame (don't transport') 
pushval (set-type (logand a-temp (b-ccnstant (- »:pane-ci2e*) ) ) dtp-fix)) 
(pucrjval top;of-stack) 

;; Temporary kludge necessary because stacks are arrays, uhich they 

;; shouldn't be. and hence sre not pane-aligned 

(if (lesc=r-po:ntcr tro-of-stack tcontroT-stocK-iou) 
(neutcp (set-tqpe Xcontrol-atack-low dtp-fix)) 
(drop-through) ) 
(parallel (puchval (Eet-tups (1- stack-pointer) dtp-fix)) ;First addr not to load 
cIcar-stark-adjuGtment) ;Leave in stack if pctsr 

( jur::p cont i nue-sg-s tack-buff cr- toad) ) ) 

(defucode so- load-state- interna I 

(iiemread U a-stack-group-entering (b-constant (field-word-offset ' sg-frame-pointer) ) ) ) 

(assign frame-pointer next-reaory-data) 

(assign stack-pointer next-memory-data) 

(assign Xcontrol-stack- low next-menicry-data) 

(assign Xcontrof-stack- i im i t next-mcroru-data) 

(assign tbinding-stack-low next-memory-data) 

(assign Xb i nding-stack- I imi t next-mcmory-data) 

(assign Xb inding-stack-pointer next-memory-data) 

(ass ion Xcotch-block- I i St noxt-memcry-data) 

(parallel (declare-memory-t iming datiJ-cycle) 

(transport data) 

(assign tcurrent-stacK-group-status-bi ts memory-data)) 
(assign tcurrcnt-stacK-group a-stack-group-enter ing) 

;; Set the active bit in this SG's stored state, clear other nonresumab t I i ty bits 
(memread (+ a-stack-group-enter ing (b-constant (f isld-word-of f set 'sg-act ive-bi t) ) ) ) 
(parallel (check-data-type memory-data dtp-fix) 

i .. < J3ss'9" a-tcmp (andc2 memory-data (b-constant (bute-«ask sa-nonresumabi M ty) ) ) ) ) 
(parallel (store-contents (set-type (Icgior a-temp (b-constant (byte-mask sg-acti v3-bi t) ) ) 

dtp-fix) 
not-pointer) 
(return))) 

(defucode cont inue-sg-stack-buf fer-load 
;; Load the current frame into the stack buffer, along with the rest of the page 
:: containing the beginning of the current frame. 
(parallel (assign xbas next-on-stack) 

(call stack- load- loop)) 
;; Decide how much stack buffer to use 
(parallel (assign tstack-buf fer-low top-of-stack-a) 

(assign top-of-stack top-of-stack-a) 

(cal l-and-return-to set-stack-buffer- 1 imi t 

8g-stack-buffer-load-setup-«ap))) 

(defucode sg-stack-buf fer-load-setup-map 
:; Locp mapping ail paoes that are in the stack buffer 
;; including those beyond the current end of the stack. 

;; Contorted way of writing it is to avoid getting too many blocks in a row 
;; i can t see a reaconable way to share code with normal stack-buffer maintenance 
(newtop {+ top-of-stack-a (b-constant *page-si2e») ) ) 
(parallel (assign vma (- top-of-stack-a (o-constant «page-8i2e*) )) 

(cai I msp-page-to-stack-buf fer)) 
(if (lesser-pointer top-of-stack Xstack-buffer-I imi t) 

(jump sg-stack-buffer-load-setup-map) tshould be goto, but,.. 
(drop-through)) 
;; Finish loading up those frames, finish popping stack-load-loop' s state 
(parallel (for-effect (popvaD) 

(c I ear -stack-adjustment) 

(call ad just-frame-buffer-underf low-bits)) 
;; Now stash the argument in the stack, if wanted 

(if (greater-f ixnum-unsigned (sg-arg-status Xcurrent-stack-group-status-bi ts) 

Xsg-arg-break) 
(assign next-on-stack a-stack-group-argument) 
(drop-through) ) 

;; Set up to swap in the bindings 

(assign b-binding-boundary Xbinding-stack-low) 

(parallel 

(assign a-stack-group- lock (set-tupe (a-constant B) dtp-fix)) 

(jump cont inue-sg-swap-in-bindingi) ) ) 
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(defucode cont inue-fg-swap-in-btndings 

( i f (greater-pointer b-binding-boundary Xbinding-stack-pointer) 
;; Done uhoic binding stack — weVe ait done 
(parallel (assign a-stack-group-lock quote-nil) 

(jurrr popj)) 
(drcp-tnrounh)) 
;; Read the pointer to the bound location 
(memread (1+ b-binding-boundary) ) 
(paral let (transport) 

(acsign b-tenp ffismory-data) ) 
;; Read the bound contents of the bound location, checking write access 
■(rtcnread-ur i te b-Dinding-boundary) 
(parallel (transport bind) 

(assign a-ternp-2 iremory-data) ) 
;; Read the current ccnxents of the bound location 
(mefnread b-temp) 
(parallel (transport bind) 

(assign a-tenp memory-data) 

(assign b-temp memory-data)) 
:: Ur i te the bound contents there (preserve cdr code) 
(store-contents a-tefnp-2 (cdr b-terrp)) 

;; Store current contents into binding stack (better not pc I sr ! ) 
(assign vTT.a o-bindinq-boundary) 
(store-ccntcnts a-tcrnp) 
(parallel (assign b-binding-boundary (•»■ b-binding-boundary (a-constant 2))) 

(jump cont inue-sg-swap-in-bindings) ) ) 



F:>linach>ucode>proto-trap,1 Isp.l 

;;; -«- node:Ltsp; Packaaetll) cro; BasetS; Lowerc»se:yes -*- 
;;: (c) Copyright 13S2, Symbolics, Inc. 

5 flicrocode for Trap Handling on "prototype" Bachine 

;Get defraicro and all his hosts 

(declare (ccnd ((not (status feature Imucode)) 
(load •udcis))}) 

; Invi stble-pointer traps 

;If transporting uas needed, it has happened already 
;Time« 2 cycles trapping + 3 cycles here 
5+ 3 more because of the ter.porary memory control 
(defucode-at-loc inviz-trap 1C012 ;trap-2 handier 
(para I lot 
(trap-save) 

(assign vma a-vma-copu) tget the «cmoru-data aaain 

(assign b-vma a-vma-copy) ) 
(star t-mescry read) 
(nop) 
{paral lei 

(assign vna memory-data) 

(if (cata-type? memory-data dtp-body-foruard) 
;; Body forward points to header forward 
(seouent iai 

(start-memory rc3d) 

(assign b-vma (- b-vma a-vma-copy)) ;Offset into structure 
(assign vma (+ memory-data b-vma))) ;Address word in target structure 
(drop-through) ) ) 
(trap-restore 

(stert-memory read) 
(assign o-vma a-vma-copy))) 

;Halt here if ue accidentally popj with 17 tn the CSP 
(defucode-at-loc no-i fu-present 1/774 

(parallel (halt no-i fu-present) (jump no- i fu-present) ) ) 

(defucode-at-loc error-trap 10018 ;trap-0 handler 

(paral lei (trap-save) 

(lisp (enter-error-handler)) 

(if (not (zsro-fixnum (sg-hai t-on-error Xcurrent-stack-group-status-bi ts) ) ) 
tparalfel (halt crror-in-error-handler) (jump error-trap)) 
;; FiKup the stack first, since we need to push some stuff 
teal l-and-rcturn-to restor«-«tack-pointer error-trap-1) ) ) ) 

(defucode error- trap-no-res tore-stack 
(paral lei (trap-save) 

(I isp (enter-error-handler) ) 

(if (not (zero-fixnum (sg-ha I t-on-error Xcurrent-stack-groun-status-bi ts) ) ) 
(parallel (halt error- in-error-hand I er) (jump error- trap)) 
;; Fixup the stack first, since we need to push some stuff 
(goto error-trap-1)))) 
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(defucode erpor-trsp-1 

:; I f sn error occurs, halt 

<a£Eic?n (sg-halt-on-error Xcurrent-stacK-group-atatus-bi tsl (b-constant D) 
;; Push the address of the microinstruction that signaMed the error 
asstgn b-remp (logand (pop-controt-stack) (b-conatant 37777))) 
(puEhvat (set-type b-ternp dtp-fix)) 



(pushval (set-type a-vma-copy dtp- f ocat i ve)) 
;; McKe the pc point such as to retrL 



,.^ , . 'y t^e failed instructione The error handler is 

;; likely as not going to mess with our etate anuuau. 
;; The stack uas afreadu restored above, 
(take-pre-trap signai-errcr preserve-stack)) 

F:>lmach>ucode>PREDICAT£.LISP,14 

;•• -»- HoderLtsp; Packaac: Micro; Base: 8; Lowercase: yes -*- 
;;; (c) Copyright 1932, SyfRboJics. Inc. 

• tlicrocode for priwitive predicates 

;Get defmicro and all his hosts 

tin 

(declare (cond ((not (status feature Inucode)) 

(load *udcls)))) 

(defucode truel 

(parallel (newlop quote-t) 

(next- instruct ion) ) ) 

(defucode falsel 

(parallel (neutop cfuote-nt!) 

(next- instruct ion) ) ) 

(definst eq (no-operand needs-stack) 
(parallel 

(if (equa l-typed-pointer top-of-stcck next-on-etack) 
(ooto true!) 
(goto falsel)) 
(decrement-stack-pointer) ) ) 

(definst eql (no-operand needs-stack) 
iparal let 

(if (equal-typed-pointer top-of-stack next-on-etack) 
(goto truel) 
(goto falsel)) 
(deer ement-stack-po inter) 
(check-data- type-and-di spatch 

(next-on-stack dtp-float dtp-extended-number) 
;; If the types differ, aimply return nil 
:; This has the bug that flonum NAN* a pass through, 
( (f lonun-f ixnum extnutn-f ixnum extnum-f lonum f lonutn-extnum) 

(goto fai sel) ) 
;; If the tupes are the same, do appropriate comparison 
;; Due to IEEE standard* non-eq flonuras can be equal, 
;; plus and minus zero for example 
( (f lonuffi-f lonum) 

(goto fequal ) ) 
( (extnum-cxtnum) 
(jump extnum-equa! ) ) ) ) ) 

(definst not no-operand 

(if (data-type? top-of-stsck-a dtp-nil) 
(goto truel) 
(goto falsel))) 

(definst atom no-operand 

(if (data-type? top-of-stack-a dtp- list) 
(goto falsel) 
(goto truel) ) ) 

;This is the Common Ltsp version of LISTP, not the present one 

(comment 

(definst listp no-operand 

(if (data-tyoe? top-of-stack-a dtp-list dtp-nil) 

(aoto truel) 

(goto fatsel))) 
) ;end comment 

(definst floatp no-operand 

(if idata-type? top-of-stack-a dtp-f(oat) 

(goto truel) 

(drop-throu:ih) ) 
(if (not (data- tune? top-of-atack-a dtp-cxtended-number) ) 

(goto falsel! 

(drop-through) ) 

% Here see if it's an extended-precision float 

(jump falsel)) 
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(definst nuKDfirp no-operand 

(if (data- type? top-of-stack-a dtp-fix dtp-float dtp-extended-number) 
(goto truel) 
(goto falsel))) 

(definst symbol p no-operand 

(if (data-type? top-of-stack-a dtp-syr.bol dtp-nil) 
(goto truel) 
(goto false!))) 

, (definst arrayp no-operand 

(if (data-type? top-of-stack-a dtp-array) 
(goto truel) 
(goto faisel)) ) 



F:>LMach>Uccde>HET.LISP.71 

;;; -»- riodetLisD; Packaac: Hicro; Base: S; Lowercase: yes -«- 
;;; (c) Copyright 13S2, Sijnfco I i cs, Inc. 

(reserve-scratchpad-aesiory 2E20 2531 314 324) 

(associate-di cpatch-cues net-micro-ststus smet-ntcro-status-codes*) 
{Qii ine-cnumerated-va i ue-;:onstant2 «n3t-fn i cro-status-codec*) 
(defato«ic-t.yte-f ieid net-micro-status (4 C) ttnet-micro-status) 

(defareg Xnet-btock-pc inter) ;Pointer to next block 

(defareg Inet-rjemoru-addrGSs) ;Ad.'iress in this block 

(defareg inet-uord-count) :Uord ccunt of this block 

;; Packet ue are receiving into or -1 

(aefcrcg tnst-packet-being-recei ved (set-type -1 dtp-fix)) 

;; Packet we are transmitting cr -1 

(defareg inet-packet-being-transmi tted (set- type -1 dtp-fix)) 

(defareg Xnet-contro I -address) tAddress of the control register 

(defareg net-dma-teap) 

;;; A network unit is 512 bit ti«es, but the board times 128 bit times, so that 

;;; we must multiply by 4 

(defareg anet-backof f-count) ;12us units to back off 

(aefareg Xnet-next-backof f ) ;nask of units to back off 

tbetwcen 2''n-l where n is 
;the nth retransniission + 2 

(defbreg Xnet-address-1) ;Our net address 

(defbreg lnet-adcires3-2) 
(aefbreg net-b-tcnip) 

(defmicro set-net-status (net-status-code) 

•(assign ^net-nicro-status (set-type , net-status-code dtp-fix))) 

;Uakeup the net service task 

;Tnic is called in the DIIA task usually, but can also be cailedby the cr.ulator 

(defmicro wakeup-net-serv i ce 

• i par a I lei (assign service- task-requests 

(logior ssrvice-task-requests 

(b-const3nt (byte-mask XXservice-net) ) ) ) 
(wakeup-task tdev i ce-serv i ce-task) 
)) 

(defmicro terminate-net-dma {nct-status-code ^optional (end-p t)) 

* (sequent iai 

(set-net-status .net-status-code) 
(net-control ni 1 , end-p) 
Iparal iei (wakeup-net-cervice) 

(jump net-dma-dead) ) ) ) 

(defmicro start-net-dma (location) 
' (wr t te-task-state Xnet-dma-task 

(a-constant ' (bui Id-task-state cpc , location 

npc (npc-successor .location) 
csp 17)))) 

(defmicro io-board-bug-dsfay 
'(parallel (disable-tasklng) 

(declare-menory-t ining (next active-cycle)))) 

(eval-when (compile load eval) 

(defun net-buffer-address (dma-p dicmiss-p end-p) 
(logior (if rima-a 1 0) 

(i f d(smiss-p 2 0) 

(if end-p 4 B) 

18)) 
};fcvsl-when compile load eval 
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(deftPicro rcad-net-buff er (^optional (dtsmtss-p nil) (cnd-p nil)) 
(let ((dev-addr (net-buf fer-addres-: nil disniss-p end-p))) 

• (parai lei (extra- 1 ine-to-dri ve-lbus) 

(read-lbus-dev iob , dev-addr) 
,(if dismiss-p * (di smi ss) ) ) ) ) 

(defwicro service-read-net-buffer (dopt tonal (dismiss-p nt !) (end-p nil)) 
(let ((dev-addr (net-buffer-address nil dismiss-p end-p))) 

* (para I lei (exira-t ir.ie-to-dr i ve-lbus) 

(read-lbus-dev iob , dev-addr) )) ) 

(dcfrcicro service-nGt-ccntrol (^optional (dismiss-p nil) (end-p nil)) 
(let ((dev-addr (net-buf fer-address ni! dismiss-p end-p))) 
'(parallel (wr i te-ibus-dev iob , dev-addr nil)))) 

(def micro transmit-dma (addr ioptionai (dismiss-p t) (end-p ni!)) 
(let ((dev-addr (net-buffer-address t disaiss-p end-p))) 

'(parallel (start-cierrory read physical .addr dma iob , dev-addr) 
,(if dismiss-p * (disraissJ ) )) ) 

(defmicro rcceive-dma (addr fioptional (dismiss-p t) (end-p nil)) 
(let ((dev-addr (net-buffer-address t di sm i ss-p end-p) ) ) 

•(parallel (start-memory ur ite phusical ,addr draa iob , dev-addr) 
(assign ,addr (1+ ,addr)) 
,(if dismiss-p '(dismiss))))} 

(defmicro net-control (fioptionat (input-pnil) (dismiss-p t) (end-p nrl)) 
(let ((dev-adcir (net-buffer-address nil dismiss-p end-p))) 
Mparil tel , (i f input-p 

•(for-effect (read-lbus-dev iob , dev-addr)) 
Mwr i te-lbus-dev iob .dev-addr nil)) 
,(if disniiss-p '(dismiss))))) 

(defmicro increment (location ^optional (fixnum-p t)) 
(if f i xnur-p 

Massign .location (set-type (1+ .location) dtp-fix)) 
(assign .location (1+ Jocation)))) 



F:>lmach>ucode>nBITBLT.LISP.22 



-»- ModerLisp; PacKaaerHicro; Base: 8; Lowercase: yes 
Ic) Copyright 13S2, Symbolics, Inc. 

8ITBLT «icrocode for 3G80 



The pclsring theory: 

Reads can be repeated with no harmful effects, writes cannot be (in most cases). 
State is not permanently updated until a ur ite is consummated. 
After every write, state should be updated so that if the next «effioru operation 
faults and pel srs, that write will not be repeated (the bttbit row will be shorter), 
lo avoid the overhead of doing this for every write, we have block mode 
operations that only update the state after writing a block of words. 

For the block Bode things, we use a buffer that can be saved. See next+1 page. 

For the short-row things, when the destination is split across two words 
we check write access to both words before ■odifying either of them. 
No pclsring problems if the operation depends on neither operand. 

Uhen there is a partial word at the front, do it and then advance the arguments 
so the bitbit ts word aligned in the destination, Uhen there is a partial word 
at the end, when we get there the arguments have been advanced. 

(rcserve-scratchpad-memory 24S8 2478 323 338) 

(defiicrp waiting-for-uemory ;docuraentation only 

'(nop)) ^ 

(defnicro abus-array-data (ibodu body) 
•(parallel 

(transport data) 

(check-data-type «emory-data dtp-fix) 

.•body)) 
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{defwicro assign-vma-of f set (which irest stuff) 
{selectq which 

(S '(assign vma (+ bb-s-row-addr bb-s-offset ,«stuff))) 
(0. • (assign vma (+ bb-d-row-addr bb-d-offset , •stuff))) 
(S-ahead ^(assign vma (+ bb-s-row-addr bb-s-off set-ahead ,«5tuff))) 
(otherui se 
(terror "asstgn-vma-of f set knows about only S and D, not ^S" which)))) 

(defBiicro paral le!-wi th-s-access (offset 4body body) 

(■ake-«emory-access * bb-s-row-addr *bb-8-offset offset body '(read))) 

(defaicro para! lel-wi th-d-access (offset ibody body) 

i»ake-«emory-access 'bb-d-row-addr 'bb-d-offset offset body * tread))) 

(defaicro paral I e ! -wi th-d-access-checK-wr J te (offset &body body) 
(■ake-«emory-acce58 *bD-d-row-addr 'bb-d-offset offset body (read write)) 

(eval-uhen (eva! coffipi !c load) 

(defun Kake-rnemory-access (baseaddr offset-sym offset body nemory-iiodes) 
(or leq offset offset-sym) 

(equal offset * (W ,of f set-sym) ) 

(and (cq offset-sym 'bb-s-offset) (eq offset 'bb-s-off set-ahead) ) 
(ferror "*rS is not a recognized offset for -vS" offset offset-sym)) 
(let« ((body (reverse body)) 

(finally ' (abus-array-data , (car body)))) 
(do ((II (reverse 

*( (assign vma ,(if (atom offset) 

•(+ pbaseaddr .offset) 
•(+ ,baseaddr .(second offset) 1))) 
(start-itiencry ,»memoru-modes) 
(wai t ing-for-memory) ) i 
(cdr l-i)) 
(body (cdr body) (cdr body)) 
(Ij) 
((and (nut I ID (nul I body)) 
• (seausntial ,•! .final iy)) 
(cond ((null I!) (push (car body) D) 
((null body) (push (car 11) I)) 

(T (push *ip3raliel .(car !l) .(car body)) !)))))) 
) ; eva I -when 

(def»icro 31- (operand) 

' (- (b-constant 31.) .operand)) 

(defmicro incr-d-of f set () 

•(assign ub-d-offset (1+ bb-d-offset))) 

(defmicro decr-d-of f set 

•(assign bb-d-offset (1- bb-d-offset))) 

(defmicro inc. -wrap-s-offcet 
• (sequent iai 
(para I Is I 

(assign bb-s-offset (1+ fct-s-of f set) ) 
(assign b-ter.p-3 cbu3) ) 
(if (greater-or-equai-f ixnurn b-tcn-.p-S bb-s-rou- length) 
(parat lei 

(lisp (format T "*Mi»>Urappinq around on bb-s-offsct from -^d* " 

(loi:32 (tr ^lib-s-of fset) ) ) ) 
(acsign bb-s-offsst (b-constant 0))) 
(drop- through) ) ) ) 

(defRiicro decr-wrap-s-of f set 
'(paral let 

(assign bb-s-offset (1- bb-s-offset)) 
(if (minus-f ixnurn obus) 
(par a I let 

(lisp (format t ''*^>»Decr wrapping around on bb-s-offset")) 
(assiqn bb-s-offset (1- bb-s-rcw-length) ) ) 
(drop-through) ) ) ) 

(defmicro incr-wrap-s-off set-ahead 
* (sequential 
(para I lei 

(assign bb-s-of fset-shead (1+ bb-s-offset)) 
(assign b-temp-3 cbus)) 
(if (greater-or-equ3l-f (xnum b-temp-3 bb-s-row-Icnnth) 
(par a I lei 

(lisp (format T "*^>>>Urapping around on bb-s-offset from «*d." 

(low32 (tr ^bb-c-offset-ahead)))) 
(assign bb-s-of fset-Ehead (b-constant 8))) 
(drop-throuGh) ) ) ) 

(defmicro decr-wrap-s-of f set-ahead 
*(paral lei 

(assign bb-s-of f set-ahead (1- bb-s-offset)) 
(if (minus-f ixnurn obus) 
(paral lei 

(lisp (format t ''-^>»Decr wrapping around on bb-s-cf f set") ) 
(assign bb-s-of f set-ahead (1- bb-s-row-length) ) ) 
(drop-through) ] } ) 
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parai !el) 



(defmicro store-word (datum finest options) 

•(store-contents (set-type .datum dtp-fix) not-pointer . .options)) 

;; the godda.Tn strrulator cor.piles 

:; (parallel (assign ,..) (return)) 
; ; into 

;; (prog ... (return nil) (setq ,..)) 
(defmicro para Me I -wi th-return l&Dody stm) 

*{.(if (eq «aiachine-versicn* * sins) 'sequential ' 
.«stm 
(return))) 

(defmicro via-xbus (source) 

(make-microdata 'xbus (get-to-xbus source))) 

(dcfvar «fp-off set-names* ()) 

(defaacro def-fp-of f sets (irest names) 
(loop for i upfrora 

for name in names 

append ' { (defatomicro ,name (arem (frame-pointer ,i))) 
(dcfppop ,natno J fp-offset) 
(or (memq '.name «fD-off set-names*) 
(push *,name «fp-of f set-naraes*) ) ) 
# into foo 

finally (return * (progn 'compile .•foo)))) 

?;decode fp offset numbers into symbols. Debugging onltj. 
(defun dfp (&rest numbers) 
(loop for number in nurr.bers 

collect (locp for name in *fp-off set-names* 

uhen (equal (get name * fp-offset) nufflber) 

return name 

finally (return numfcer)}}) 

;; Define arguments/state for BITELT instructions. Note that these nust be 
;; relative to fP, not to the top of the stack, since there might be a 
;; saved bi tbi t-buf fer on the stack if the instruction was interrupted, 
(def-fp-of fsets 
bb-arg-a(u bb-arg-width bb-arg-height ;rtsp arg 
bb-arg-from-array bb-arg-frofn-x bb-arg-from-y ; I i sp arg 
bb-arg-to-array bb-arg-to-x bb-arg-to-y ;Iisp arg 
bb-width ;ucode arg 

bb-s-data-addr jucode arg 

fcb-s-rou-offset ;ucoae arg 

bb-9-offset ;ucode arg 

bb-s-bttpcs ;ucode arg 

bb-s-row- length ;ucode arg 

bb-d-d3ta-addr ;ucode arg 

•ucode arg 
•ucode arg 



bD-d-of f set 
bb-d-bi tpos 



bb-event-count 
bb-atu-operat ion 
) 

;;; Some temporaries. 

(def ine-b-temps bb-constant 
bb-s-worri 
bb-s-rc .-addr 
bb-d-row-adc^r 
bb-utdth-b 
b-biock-size) 

(defareg bb-constant-a) 
(defarcg bb-identi ty) 
(defareg bb-s-wordZ) 
(defareg bb-a-temp) 
(defareg fcb-s-off set-ahead) 
(oefareg a-block-s i ze) 



; ucode arg 
; ucode arg 



;Value to store or to XOR in 

; temp (source word) 

: start of current source row 

{Start of current destination row 

;copy of width on B side (sometimes) 

; number of words in block 

;A-side copy of bb-constant 

: Background to dpb into when doing part word 

; temp (other source word) 

;8-offset not finalized yet (if pclsr) 
; number of words in block 



;;; Bi tbi t-buf fer hair 

(eval-when (compile toad eval) 
(defconst n-bi tbi t-buf fers 8)) 

^. Mprogn 'compile^ ;B-memory buffer for block-mode operations 

. .(loop for I from 8 below n-bi tb! t-buf fers ^Hcioviuiia 

collect '(defbreg . (f intern "BITBLT-BUFFER— D" i)))) - 

(defmicro bi tb!t-buffer (i) 

(fintern "BI TBLT-BUFFER-^D" i)) 

;-— this defareg noes in some other file 

;If this register ts non-zero and we pclsr, eave-bt tb I t-buf fer must be 
;called after restoring the stack pointer. 
(defareg bi tbi t-buf fer-act ive 8) 
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Uc first computs the result n words at a time into the bi tbi t-buf fer, 

and then store it into the destination (in one case the uhoie buffer 

is rotated by 1 to 31 bits as it is being stored). 

The bi tbt t-buf fer is "active** while ua are storing it into the destination. 

The bitdlt buffer Dust be active while we are modifying the destination, 

since the words copied into the buffer might overlapped with parts of 

the destination we have already modified. 

A pclsr while the br tbl t-buf fer is active will copy it into 

the stack, set first-part-done, and clear bi tbt t-buffsr-active. 

A restart with first-part-done set will proceed normally until it comes tine 

to store the bi tbl t-buf fnr. At that time, f irst-part-dono is seen, the 

bi tbl t-buf fer is restored from the stack (replacing the possibly-erroneous 

contents that were just computed), and execution then proceeds normally. 

The contents of the bi tbl t-buf fer are assunted to have valid data type tags. 

For now, they could be forced to fixnum, but in the future we may have 

other instructions using this buffer and its save/restore uechantsra. 

Still need to fix microcompi ler to default cdr source from 6bus correctly 

;Call here if we pclsr with the bi tbl t-buf fer active 
(defucode save-bi tbl t-buf fer 
tf- '{seguential . 

, iloop for i from below n-bi tb I t-buf fers 

collect Mpushval-with-cdr (bi tbl t-buf fer ,i)})) 
(assign first-part-done (b-constant 1)) 
(parallel 

(assign bi tbl t-buf fer-active (b-constant 0)) 
(return))) 

jCall here when about to start storing the bi tbl t-buf fer 
;This is actually a micro so that the first instruction of the routine 
joets open-coded into the caller 

;Thi5 is hairiiy bummed to make the normal case go in only one cycle 
;(if the trap is not taken then the obus has -1 on it) 
(dcfmicro act ivate-bi tbl t-buf fer 
Mparal lei 

(assign bi tbl t-buf fer-act i ve obus) 

(trap- if (bit-test frarte-misc-data (b-constant (byte-rask first-part-done))) 
act ivate-saved-bi tbl t-buf fer) )) 

;Ue also need this closed-subroutine version 
(defucode act ivate-bi tbl t-buf fer 
(para I lei 

(act ivate-bi tbl t-buf fer) 

(return))) 

(defucode act ivate-saved-bi tbl t-buf fer 
(parai iei 

(trap-save) ;Retry the assign, trap- i f upon return 

#, * (sequent iai 

,«(lcop for i from (1- n-bi tb I t-buf fers) downto 8 
col iect ' (para I lei 

(assign (bi tbl t-buf fer , i) top-of-stack-a) 
(dccrement-stack-pointer) ) ) ) ) 
(parai lei 

(assign first-part-done (b-constant B) ) 
(return)}) 

;Cal I here uhen done storing the bi tbt t-buf fer 
(defucode rieact ivate-bi tbl t-buf fer 
(parai let 

(assign bi tbl t-buf fer-act ive (b-constant 0)) 

(assign top-of-stack top-of-stack-a) :Could have been bashed by activate,.. 

(return))) 

(defmicro r«ad-bb-s-uord 
* (parai lei 

(assign a-temp (-♦• bb-width-b bb-s-bi tpos) ) 
(call read-bb-s-wordl))) 

; a-temp has the number of s bits needed relative to bit 8 of the first word 
(defucode read-bb-s-wordl 
(assion-vma-of fset s) 
(parai lei 

(assign byte-r (32- bb-s-bi tpos) ) 
(star t-«emory read)) 
(para I lei 

(wa i I i ng-f or-»emoru) 

(if ( lesser-or-equal-f ixnum a-temp (b-constant 32.)) 
;; source is entirely within one word 
(parai let-wi th-return 
(abus-arr ay-da t a 

(assicjn bb-s-word (logxor bb-ccnstant (rotate «eracru-d3ta byte-r))))) 
t! source is split across two words 
(sequent iaI 

(abus-array-data 

(assign bb-s-word (rotate memory-data byte-r))) 
(incr-wrap-s-off set-ahead) 
(assign-v»a-of fset s-ahead) 
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(parai iei 

(start-ncBory read) ;byle-r is already ok 

(paral let 

(uai t ing- for -memory) 

(assign byte-s (i- a-temp))) 
(abus-array-data 

(assign Db-s-word (dpb memcry-data byte-s byte-p bb-s-word) ) ) 
(paral li ! -ui th-return 

(assign bb-s-uord (logxor bb-s-uord bb-constant-a) ) ) ) ) ) ) 
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Assumptions about setup: 
bb-constant has: 

>> for constant operations (0,-1): the constant; 

» for operations dependent only on source or destination (x, -*x, y, f^) : 

a S for x»y or -1 for *x,^y; 
>> for onerations dependent on both s and d: for those using source directly, 
and -1 for those that want the source complemented, 

(defucode bb-copy-stuf f-to-b-side 

(ass i en bo-s-rou-addr (+ bb-s-data-cddr b-temp)) 
(paraTlel-ui th-return 

(assign bb-d-row-sddr bb-d-data-addr) ) ) 

(def macro def inst-bi tb! t (name source destination neither both) 
*(definst .name no-operand 

(parallel (assign b-temp bb-s-rou-offset) 
(call bb-copy-stuff-to-b-side)) 
(dispatch-af ter-this (parallel (Idb bb-alu-operat ion 4 0) 

:; Set up constant needed for the most comncn case 
(assign bb-constant (via-xbus (b-constant 0))) 
(assign bb-constant-a (via-xbus (b-constant 0)))) 
(assign bb-width-b bb-uidth) 
((0) ;0 

(ooto ^neither)) 
((I) :x«y 



(paral iel 

((2) 
(ass ion bb 

(parallel 

((3) (returnjy 
((4) 
(paral let 

{(5) (goto 
((6) 
(parai let 

((7) 
(paral Iel 

((8.) 



(ass ion bb- identity (a-constant -D) 



(paral Iel 

((10.) 

(paral Iel 

((11.) 

(ass ion bb 
(paraT !e! 

((12.) 
(para! Iel 

((13.) 

(ass ion bb 
(paral le I 

((14.) 
(paral lei 

((15.) 
(paral Iel 



assign bb- identity (a-conatant -1)) 
jump ,both))) 

;'vx*y 
identity (a-constant -1)) 

assign bb-rcnstant (a-constant -D) (assign bb-constant-a (a-constant -D) 
jump ,both))) 

;y 

;x«^y 
assign bb- identity (a-constant -1) ) 
jump ,both))) 
source)) ;x 

;x xor y 
assign bb-identity (a-constant 0)) 
jump .both))) 

;x+y 
assign bb-identity (o-constant 0)) 
juntp ,both)}) 

; *x*^y 



(paraTi 

((9.) 

(assign bb-identity (a-constant 81) 



assign bb-constant (a-constant -1) 
jun:p .both))) 

;*-x xor t) 



assign bb-constant (a-constant -1) 
jump",botn))) 

•-VX 

assign bb-constant (a-constant -1) 
jump .source))) 

identity (a-constant 0)) 

assign bb-constant (a-constant -1) 

jump .both))) 

;^y 
assign bb-constant (o-ccnstant -1) 
jump .destination))) 

;x+*-y actually. *'(^x*y) 
identity (o-constcnt -1)) 
assign bb-constant (a-constant -1) 
jump .both))) 

;-vx+^y actually, --(x^y) 
assign bb-identity (a-constant -1) 
jump .both))) 

assign bb-ccnstant (a-constant -1) 
jump .neither)))))) 



(assign bb-constant-a (a-constant -1)) 

(assign bb-constant-a (a-constant -1)) 

(assign bb-constant-a (a-constant -1)) 

(assign bb-constant-a (a-constant -1)) 

(assign bb-constant-a (a-constant -1)) 

(assign bb-constant-a (a-constant -1)) 

(assign bb-constant-a (a-constant -D) 



(def inst-bi tbi t tbi tbi t -short-row 
ubi tb! t-shcrt-rcw-source 
UD i tbl t-short-row-dest Inat ion 
ub I tb I t-£hnr t-row-ne i ther 
ubi tb! t-£hcrt-rou-both) 
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(def inst-bi tbU tbi tbi t- Icng-rou 
ubi tbi t- I CPQ-rou- source 
ubi tbl t- long-row-dest inat ion 
ubi tbI t- long-rou-nei ther 
ubi tbl t- long- row-both) 

iricf inst-bi tb I t tbl tbl t- lorn-row-backwards 
ubi tb I t- 1 onc;-rou-Eource-b.'3Ckw2rd3 
ubi tbl t-!ong-row-dest inat ion 

ubi tbl t- long-rou-net ther ; direct ion i mmat cr iai 

Ubi tbl t- long-rcw-both-bjcKward3) 

(defucode ubi tbl t- short -row-source 
(read-bb-s-word) 

(asstnn a-temp (•»- bb-uidth-b bb-d-bi tpos) ) 
(parallel 

(assign byte-s (- a-temp (b-constant 32.) 1)) 
(if (Tesser-cr-equal-f ixnum-unsigned a-temp (b-constant 32,)) 
;; destination is entirely utthin on© word 
(parai lel-wi th-d-access bb-d-of fset 
(assign byte-s (1- bb-width)) 
(assign byte-r bb-d-bi tpos) 
(paraTlel-ui th-return 

(store-uord (dpb bb-s-uord byte-s byte-r iiemcry-data) ) ) ) 
;; destination is split across two words 
;; must access-check them both before Bodifyino either 
(sequential 
;; compute the high byte 

(paral lel-wi th-d-iccess-checK-urite (1+ bb-d-offset) 
(assign byte-r bb-d-bi tpos) 

(assign a-temp (Idb bb-s-uord byte-s bute-r •emoru-data) ) ) 
;; compute and store the low byte 
(paral lei-with-d-access bb-d-offset 
(assign byte-s (31- bb-d-bi tpos) ) 

(store-word (dpb bb-s-word byte-s byte-r memory-data) block)) 
;; now store the high byte. This cannot fault 
(paral lel-ui th-return 

(store-word a-temp block)))))) 

(defucode ubi tbl t-short-rou-dest tnat ton 
(assign a-temp (+ bb-width-b bb-d-bi tpos) ) 
(paral lei 

(assign byte-s (- a-temp (b-constant 32.) 1)) 
(if (U'sser-or-equal-f ixnum-unsianed a-temp (b-constant 32.)) 
;; destination is entirety within one word 
(paral le!-wi th-d-access bb-d-offset 
(assign byte-s (1- bb-width)) 
(assign bute-r bb-d-bi tpos) 
(paral le I -wi th-return 

(store-word (iogxor (dpb bb-constant byte-s byte-r 0) memory-data)))) 
;; destination is split across two words 
;; must access-check them both before modifying either 
(sequential 
;; compute the high byte 

(parallel-wi th-o-access-check-write (1+ bb-d-offset) 
(assign byte-r (a-constant 0)) 

(assign a-temp t Iogxor (Idb bb-constant fcyte-s byte-r) memoru-data) ) ) 
;: compute and store the low byte y wo^oi/j 

(paral lel-wi th-d-access bb-d-offset 
(assign byte-s (31- bb-d-bi tpos) ) 
(assign byte-r bb-d-bi tpos) 

(store-word (Iogxor (dpb bb-constant byte-s byte-r 0) memory-data) block)] 
;: now store the high byte. This cannot fault y « oc^;i 

(paral lel-wi th-return 

(store-word a-temp block)))))) 

;; The alu operation is actually a constant 
(defucode ubi tbl t-shor t-rou-ne 1 ther 

(assign a-teR.p (+ bb-width-b bb-d-bi tpos) ) 
(if (Tesser-or-equal-f ixnum a-terp (b-constant 22.)) 
;; destination is entirety within one word 
(paral lel-wi th-d-access bL-d-oftset 
(assign byte-s (1- bb-uidth)) 
(assion bute-r bb-d-bi tposl 
(paraT lel-wi th-rcturn 

(store-word (dpb bb-constant byte-s byte-r meT.oru-dat3) ) ) ) 
;; destination is split acro-ts two words, but no pctsr problems since doinq 
;; the operation twice produces the same effect 
(sequent ia I 

; ; store the low byte 
(para! tet-wi th-d-acress bb-d-offset 
(assign byte-s (31- bb-d-bi tpos) ) 
(assign byte-r bb-d-bi tpos) 

(store-wcrd (dpb bb-constant byte-s byte-r memory-data))) 
;; store the hi ah byte 
(parai lel-wi th-d-access (1+ bb-d-offset) 
(assign byte-s (1- a-temp)) 
(assign byte-r (a-constant 0)) 
(para! lel-with-return 

(store-word (opb bb-constant byte-s byte-r memory-data))))))) 
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;; The alu operation depends upon both source and destination bits 
(defucode ubi tbi t-short-row-both 
(re3d-bb-9-ucrd) 

(assion a-temp (+ bb-uidth-b bb-d-bl tpos) ) 
(if (Tesser-or-equaj-f ixpuni a-temp (b-constant 32.)) 
;; destination is entirely within one uord 
(sequent ia I 

iassicn byte-s (1- bb-uidth)) 
(assign byte-r bb-d-bitpos) 
. (parai !el 

(ccsign-vra-of f set d) 

( junp'bb-byte-alu-operat ion-dispatch) ) ) ; jcat ! 
;; destination is spiit across two words " 
(sequent iai 
;; make sure we have write access to the high byte so no pclsr after storing low 
(ass i nn-vma-of feet d 1) 
(stsrt-merrcru resd write) 
; ; store the' low byte 
(assign byte-s (3]- bb-d-bitpos)) 
(assicn byte-r bb-d-bitpos) 
(parallel 

(asslgn-vma-of f set d) 
(cal t bb-byte-3lu-ccerat ion-di spatch) ) 
;; store the nich byte ■ - 

(acsign bb-s-word (rotate bb-s-word byte-r)) 
(assign byte-s (1- a-tcr.p)) 
(assign byte-r (b-constant C) ) 
(parai ioi 

(ass ign-vTa-of f set d 1) 

( jur;.p bb-by te-a I u-operat ion-dispatch) ))) ) ; jcal I 

(boole fn K y ,.,) if fn is "abed" then 

y,5 1 2 3 A 5 G 7 



10 18 x*y ^x*y y K*^y x kU\^ x+y 

a "c 8 3, , 1^ U 12 13 14 15 

-'(x+y) --(xffy) -.X ^x+y ^y x+'wy '•x+^y -1 
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,vma and byte reas have been set up already, for DPB. 
; trashes 3-temp-2. b-temp-2, b-temp-3, but not a-temp and b-tenp. 
idefuccde bb-bute-a(u-operat ion-di cpatch 
(dispatch-after-this (parallel (start-frenory read) (Idb bb-a I u-operat ion 4 0)) 
(parai lei 

(assicin b-temp-3 (dpb bb-s-word byte-s byte-r bb-ident i tu) ) 
... -. (wai t ing-for-cier?ory) ) 

(d 2) ;;1 x*y logand ;;2 «x*y logand 
(parai lel-wi th-return 
(parai lei 

id&c I are-memory- 1 i mi ng data-cyc I e) 
(abus-arr ay-data 
r,/ 6 (store-word (logand memory-data b-temp-S) ) ) ) ) ) 

iM "'^^>*+y> - >«*-y andc2 ;;8 -(x+y) . <vx*-y andcb 
ipar a I i e i 

(dec t are-memory- 1 i ■ i ng data-cyc I e) 

(abus-array-data 

(assign a-temp-2 memory-data))) 

assign b-terrp-2 (dpb (b-constant -1) byte-s byte-r C) ) ;can't merge this... 

nn'i??.?~^-^^K'^ iogxor a-temp-2 b-tem^2}) "with t^is. 

(paraf tei-ui th-return 

/r,-^2*?^^*S°'"^ (logand a-temp-2 b-tcmp-3)))) 
(lb 3.) ;;6 x;?y logxor •;S .^(xtfy) --vx/^fy loaxor 
(parallei-wi th-return 
(parallel 

(dec tare-memory-timing data-cycle) 
(abus-array-data 
//-f 11 ,^store-word (logxor b-tcmp-3 memory-data)))))) 
((/ 11.) ;;7 x+y logior ;;11 -.x+y logior 
(parai iel-wi th-return 
(parai let 

(dec t ar e-memory- timing data-cycle) 
(abus-array-data 
/no ii®?°^®7ii°^^ (logior b-temp-3 memory-data)))))) 
(13. 14.) ;;13 x+-y - -(*x«y) icgnand ;;14 *x+Mj-'v(x«y) 
(parai lei » a 

(declare-memoru-t iming data-cycle) 
(aous-ar ray-da^ a 

(assign a-temp-2 (logand b-temp-3 memory-data)))) 
(parai lel-wi th-return 

(store-word (logxor (dpb (b-ccnstant -1) byte-s byte-r 3) a-temp-2)))))) 

;;yma has been set up alreadi^ 

(defucode bb-word-alu-operat lon-di spatch jcommonly 3 cycles (plus 1 for the call) 
(dispatch-after-this (parallel (start-memory read) (Ido bb-a i u-operat ion 4 0)) 
,,, ^, , (wai ting-for-ueniory) ;™uant to use tnis somehow... 
((12) ;;1 >c«y logand ;;2 •'K*u logand 

(parai tel 

(dec I are-memory-timing data-cue I e) 

(abus-array-data (store-word T logand bb-s-uord memory-data))) 

(return) )) 
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((4 8.) 
(parai le! 

(dec lare-memoru-t iming data-ctjcie) 

(atus-array-data (stcre-uord Unac2 bb-s-uord metnoru-data) ) ) 
^(return))) 
((6 3.) ;;S x<?y logxor ; ; 9 * ( xtf y ) --vx^^f y ioQxor 

ipara! lei 



;;11 -'x+y legion 



(dec lare-ff!emory-t iming data-cycle) 

(abus-array-data (store-word Tlogxor bb-9-word wetnory-data)) ) 

(return) ) ) 
((7 11.) ; ;7 x+y logior 
(para I lei 

(dec iare-memory-t iming data-cucle) 

(abus-array-data (store-word Ticgior bb-s-word menory-data) ) ) 

(return))) 
((13. 14.) ;;13 x+^-y • *(^x*y) ;;14 *'X+^-*(x*u) 
(parallel « » y y 

(dec I are-memory-timing data-cucle) 

(acus-arrau-data (store-word tiognand bb-s-word «emory-data))) 

(return))))) 

;;atu depends only on source bits 
(de f ucode ub i tb 1 1- i ong-row-sour ce 
(parai lei 

(assign b-temp bb-d-bitpos) 
(if (zero-fixnum bb-d-bitpos) 

(if (zero-fixnu« bb-s-bitpos) 

(goto ubitbit-al ianed-rou-source) 
:; SSSSSSSSSSS5SSSSSSS55SSSSSSS99SS 

; ; dddddddddddddddddddddddddddddddd 
(paraltei-wi th-s-access bb-s-offsat 
(assign byte-r (32- bb-s-bitpos)) 
(parai lei 

(assign bb-9-uord2 (logxor bb-constant (rotate memory-data bute-r))) 
(lisp (trace-path «/c) T ^ 

( iuap ubitb! t-d-a( igned-row-ftource) ) ) ) 
(if (equal-f ixnum b-temp bb-s-bitpos) 
. ; ;SSS5SSSSSSSSSSSSSSSSSSSS55S»999S 
; ;DDDX'ODDOO00DDDDDDDDDDDjDddddadd 
(sequent ia! 

(parai Icl-wi th-9-acces3 bb-s-offset 
(assign b-temp (32- bb-d-bitpos)) 
(assign byte-r b-temp) 

(assign bb-s-word (logxcr bb-constant (rotate •e»ory-data byte-r)))) 
(parai lel-«lth-d-access bb-d-offset 
(assign byte-r bb-d-bitpos) 
(assign byte-s (1- b-temp)) 

(store-word (dpb bb-s-wcrd byte-s byte-r Bemory-data) ) ) 
;; First partial word done, we art now the aligned case 
( incr-wrap-s-of f set) 
(incr-d-of fset) 

(assign bb-width (- bb-width b-temp)) 
(assign bb-s-bitpos (b-constant 8)) 
(parai lei 

(assign bb-d-bitpos (b-constant B)) 
(1 isp (trace-path U/b)) 
(jump ubi tbi t-al igned-row-source) ) ) 
(if (Jcsser-f ixnum bb-s-bitoos b-temp) 

; ; SSSSSSSS55SSSSSS5S5S55SS5 

;; DODDDDDDDDDDDDODdddddddddddddddd 

; ; ♦- 32-d.bi tpos — ♦ 

(sequential 

(parat lel-uith-9-acces9 bb-s-offset 
(assign byte-r (32- bb-s-bitpos)) 
(assign b-temp (32- bb-d-bitpos)) 
(assign bb-s-word {|ogxorbb-ccnst3nt (rotate ■cmory-data byte-r)))) 

; ; sssssss9sSSSES:i5SSSSSSSSS 

(para/ tet-ut th-d-access bb-d-offset 
(assign byte-r bb-d-bitpos) 
(assign byte-s (1- b-temp)) 

(store-word (dpb bb-s-word byte-s byte-r nemoru-data) ) ) 
:; First partial D word done, some S bits from first u\ 



( incr-d-of fset) 



word remain 



5 5j:°ilifi9zw?i:d further to right by 32-d.bi tpos - left by -(32-d.bi tpos) 

; ;53roo55S555DS:3S:j sssssssss 

(assign bb-s-word2 (rotate bb-s-word byte-r)) 
(assign bb-s-bitpos (-♦• bb-s-bitpos b-temp)) 
(assign bb-width (- bb-width b-temp)) 
(parai tel 

(assign bb-d-bitpos (b-constant 0))) 
(I isp (trace-path ff/d)) 
(jump ubi tblt-d-al igned-row-source) ) 
(sequent iai 
;;The high psrt of the first source word is not as long as the high part of the 
;:f)rst destination word. So extract the useful part of the first source word, 
;:and deposit into it as much of the second source word as needed to fill out the rest 
;;ot the first destination word. Then position the rest of the second source word 
;: appropriately for the inner loop. 
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♦.- 32-9 --» ~~ 

ISSS5SSSSSS999S893SS9SSSS9S9S5SSS 

DDDDDDDDDDDDDDDD DODDDDDDDDdddddd 
{psrai lel-ui th-9-acce93 bb-9-of fset 
Ussign byte-p (32- bb-s-bi tpos) ) 
(assign D-temp-2 bfc-s-bi tpoa) 

(assign bb-s-uord (logxor bb-con9tant (rotate memory-data byte-r)))) 
( incr-wrap-s-off set-ahead) 

,-— — e.d 4-- 32-9 -^ (32.d}.{32-9)-9-d 

3999999999SS99SSSS5SSSSSSSSSSSSS1 1111111111 

DDDDDDCDDDDDDDDD DODDDODCDDdddddd 
(paral lel-wi th-9-acces9 bb-9-off set-ahead 

(assign byte-r (32- bb-9-bi tpo9) ) 

(assign byte-s (- b-tenip-2 bb-d-bitpo9 1)) 

(assign bb-8-word2 (logxor bb-ccn9t2nt meraory-data) ) ) 
(assion bb-s-uord (Jpb bb-9-word2 byte-s bute-r bb-9-uord) ) 
(parallel 

(assign a- temp (32- bb-d-bi tpos) ) 

(assign D-temp obus)) 
(paral !et-wi th-d-access bb-d-offset 

(assign byte-r bb-d-bi tpos) 

(assign byte-s (1- a-tcmp)) 

<ctore-uord (dpb fcb-s-uord byte-9 byte-r memory-data))) 
;; Ue have ncu done the first partial D word. Turn into the d-aligned 

;: case, "jth the source advanced by one word fro* where It started. 

1 1 ncr-a-OTTset ) 

(assign bb-s-offset bb-s-of fset-ahead) 

(assign bo-s-bitpos (- b-tcfnp-2 bb-d-bi tpos) ) 

(asstgn byte-r (32- bb-s-bi tpos) ) 

(assign b:3-9-word2 (rotate bb-8-uord2 byte-r)) 

(assign bb-uidth (- bb-width b-temp)) 

(paral lei 

(assign bb-d-bi tpos (b-constant e) ) 

(lisp (trace-path U/e)) 

( jump ub i tb I t-d-a I i gned-row-eource) ))))))) 

(defucode ubi tbi t-al igned-rou-source x2S cycle9 per 8 worde 

(if (greater-or-equal-f ixnum bb-width (b-conetant (* S. 32.))) 
;;Fetch a block of uords into the buffer 
(sequential 

(ass tan b-temp (+ bb-s-offset (b-constant 8.))) 
(if (Tesser-f ixnum bo-s-raw- length b-tesip) 

(goto ubi tbl t-ai i^ncd-row-cource-sfow-loop) 
(sequent iai 
(paral let 

(ass ign-vma-of fset s) 
(call ubitbl t-biock-read-S)) 
(para I ie I 

(ass i gn-vrtia-of f 9et d) 
(can ubitb(t-block-write-8)) 
(paral tei 

(assign bb-9-off9et (+ bb-s-offset b-blocK-sire) ) 
(jump ubi tbl t-al igned-row-source) ))) ) 
;:Frob with what's left. Tco bad dispatch blocks are expensive. 
(if. (greater-or-equal-f ixnum bb-width (b-constant (« 4 32.))) 
(sequent iaI 

(ass inn b-temp (+ bb-s-offset (b-constant 4))) 
(if (Tesser-f ixnum bb-s-row- length b-temp) 

(goto ubi tbl t-at igned-rou-source-s low- loop) 
(sequential 
(paral let 

<assrgn-vma-of feet s) 
(call ubi tblt-blocK-read-4)) 
(paral lef 

^ass ign-vma-of f set dl 
(caU ubi tbJt-bioc*t-write-4)) 
(parallel 

(assign bb-s-offset (+ bb-9-off9et b-btock-size) ) 
( iump ub i tb I t-a I i gned-row-source-s I ow- 1 oop) ) ) ) ) 
(goto ubi tbl t-al igned-rcw-source-slow-loop) ) ) ) 

(defucode- ubi tbi t-a I i gned-row-source-s low- loop ;13 cycles per word 
(parai lel-wi th-s-access bb-s-offset ;4 

(trap- if ( lesser-f ixnum tib-width (b-constant 32.)) 
ub i tb I t-a I i gned-row-source-s 1 ou- 1 oop-done) 

rASi t ing-f or-memory) 

(assign bb-s-word llogxor bb-constant memory-data))) 
(assign-vma-of f set d) ;1 

(store-word bb-s-word) •! 

(assign bb-width (- bb-width (b-constant 32.))) ;1 
( incr-urap-s-of f set) ;2 

(paral lei ;1 

(ir,cr-d-offset) 

(I isp (trace-path #/J) 

(jump ub i tb I t-a I i gned-row-source-s I ow- ( oop) ) ) 

;Do last partial word, tf any 

(defucode ubi tbl t-al i gned-row-source-s low- 1 oop-done 
(if (plus-fixnum bb-width) 
(sequent iat 
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(para! let-wi th-s-access bb-s-of fset 

tacsicn bb-5-word (logxor bb-constant •cmory-data) ) ) 
(p2ral lel-wt th-d-access bb-d-of fset 
(assign byte-r (a-constant CJ ) 
(assian byte-s (1- bb-width)) 
(para! !e i -ui tb-return 

(storc-uord (dpb bb-s-uord byte-s byte-r »eraory-data) ) 
(Jisp (trace-path U/2))))) 
(paral lel-wi th-return 

(I iep (trace-path U/l))))} 



; bb-s-uord*. has the part tat previous source word whose address is in bb-s-offeet, 
;potated into alignrr.ent with the destination 
(defuccde ubi tbl t-d-ai igned-row- source 

(if (greater-or-oqual-f ixnum bb-uidth (b-constant (* 8. 32.))) 
;;Fetch a block of words into the buffer 
(sequent iai 

(asGinn b-tcmp (+ bb-s-offset (b-constant 8.))) 
(if (Tesscr-or-equat-f ixnum tb-e-rou- I cnath b-tcrr.p) 
(goto uhi tbi t-d-al igned-row-source-sTow- loop) 
(sequent iat 
(parallel 

(assign-vma-of fset s 1) 
(call ubi tbIt-btock-read-S)) 
(parat lei 

iassian-vma-of f set d) 
(C3 ! ! 'ub i tb i t-d-a I i gned-b 1 ock-ur i te-8) ) 
(para) lei 

(assign bb-s-of f set (+ tb-s-offset b-tilock-sizc) ) 
( junp ubi tbl t-d-a i lancd-rou-source) 1 ) ) ) 
(if (greater-or-equal-f ixnum bb-utdth (b-constant (* 4. 32.))) 
(sequent iaI 

(assign b-terup (+ bt)-s-offset (b-constant 4))) 
(if ( lesser-or -equal -f ixnum bb-s-rou- length b-temp) 
(goto ubi tbl t-d-al igned-rou-source-slou- loop) 
(sequential 
(paral lei 

(assign-vma-of fset s 1) 
(call ubi tbIt-biock-read-A)) 
(paral tel 

(assign-vma-of fset d) 

(cal I ubi tbl t-d-al igncd-block-ur i te-A) ) 
{paral lei 

(assign bb-s-offset (+ bb-s-offset b-block-sizc) ) 
(iump ubi tbl t-d-a i rgned-rou-source) ) ) ) ) 
(goto ubi tbl t-d-a f (gned-row-source-s tow- loop) )) ) 

;;Each pass through this loop stores exactly one d word. Each time through, 
;;cb-s-uord2 will have the bits to use for the lower part of the d word (already 
;; rotated into position), and another s woro will be fetched into bb-s-word. 
;;Then s-ucrd wilt get rotated when transferred into s-word2 in preparation fcr 
; ;next loop pass. 



13 cycles per word 

2 

4 



(defuccde uo i tb I t-d-a I i pned-row-source-s t ow- 1 oop 
( incr-wrap-s-off set-ahead) 
(paral lei-wi th-s-access bb-s-of fset-ahead 

(trap- if ( le«ser-f ixnum bb-width (b-ccnstant 32.)) 
ub ; Tb I t-d-a I i oned-row-source-dcne) 

(assign byte-3 (1- bb-i-bi tpcs) ) 

(assign bb-s-uord ( I oaxor bb-constant memory-data))) 
(assign byte-r (- (b-constant 32.) bb-s-bi tpos) ) 
(assign-vna-of fset d) 

(store-word (dpo bb-s-word byte-s byte-r bb-s-word2)) 
(ar^ign bb-width (- bb-width (b-constant 32.))) 
(incr-d-offset) 

(assiqn bb-a-offset bo-s-of fset-ahead) 
(parat lei 

(assign bb-s-word2 (rotate bb-s-word byte-r)) 

(I isp (trace-path #/.)} 

( ju2*.p ub i tb 1 t~a~a i i gned-row-source) ) ) 

(defuccde ubi tbl t-d-al icned-row-aource-done 
(if (pluE-f rxnutn bb-wTdth) 
(sequential 

(assirrn b-te^p (22- bb-s-bi tpos) ) ;how many bits are valid in bb-s-word2 
(if ( lesser-or-equal-f ixnum bb-width b-temp) 
;;ue have enough s bits 
(paral lel-wi th-d-access bb-d-of fset 
(assicn byte-s (1- bb-width)) 
(paral lei 

(assign byte-r (b-constant 6)) 
(acsign bb-s-word bb-s-wcrd2) ) 
(paral lel 

(I isp (trace-path ^/4)) 
(paral lel-wi th-return 

(store-word (dpb bb-s-word byte-s byte-r ireinory-data) ) ) ) ) 
;;need to aet another source word 
(sequent i cT 



4,887,235 
315 316 

(para! lel-wi th-s-?cce£s bb-s-off set-ahead 

(assign dute-r (32- bb-s-b i tpcs) ) 

(assign byte-s (1- bb-c-bi tpcs) ) 

(assign bb-s-word (ioaxcr bo-constant BCfnory-data) ) ) 
(ass-gn Db-s-yorri (ci:;b bD-s-word byte-s byte-p fcb-a-word2) ) 
(i !£r^ ttrsce-path: AVS) ) 
(p2ra! lei -wi tn-cJ-ticcess tb-d-of f set 

(assign byte-s (1- bb-uirith)) 

(assign byte-r (a-constant C) ) 

tpa'-al iel-ui th-return 

(store-word (cpb bb-s-ucrd byte-s byte-r siemory-data) ) ) ) ) ) ) 
vpsra 1 I e i 

( i isp (trace-path it/3)) 
(return) ))) 

;;alu depends only on destination bits 
(defucode ubi tb) t-ionn-rcw-dest inat son 
(if (pius-ftxnum bb-d-bitpos) 

(sequential ;fpob the first partial word 

(ass tan b-temp (32- bb-d-bi tpos)) 
(paraT te!-ui th-d-access bb-d-of f set 
(assign byte-s (1- b-temp) ) 
(assign byte-r bb-d-bi tpos) 

(store-word (logxor (dpb bb-constant byte-s byte-r 0) «enory-data) ) ) 
(incr-d-offset) 

(assion bb-width (- bb-width b-temp}) 
(paral iel 

(assign bb-d-bi tpos (b-constant 0)) 
(I isp (trace-path ff/b)) 

(jump ubi tbt t-long-row-dest inat ion- loop)) ) 
(■achine- version-case 
( (sin) (paral le) 

(i isp (trace-path #/a) ) 

(jump ubi tbi t-long-row-dest inat ion- loop))) 
(otherwise (goto ubi tbi t-long-row-dest inat ion-loop) ))) ) 

(defucode ubi tbi t-iong-row-dest inat ion-loop ;2S cucies per 8 words 

(if (greater-or-equa!-f ixnum bb-width (b-constant (« 8. 32. T)) 
;;Fetch a btocK of words into the buffer 
(sequent iai 
(para! lei 

(assign-vma-of f set d) 
(call ubi tbf t-blocK-rc3d-8)) 
(parat Iel 

(assign-vma-of f set d) 

(cal i-and-return-to ubi tbi t-bf ocK-wr i te-8 

ubi tbi t-long-row-dest inat ion- loop)) ) 
:;F.rcb with what's left. Too bad dispatch blocks are expensive, 
(if (greater-or-equal-f ixnura bb-width (b-constant (» 4 32,))) 
(sequential 
(para) Iel 

(ass ign-vtr.a-of f set d) 
(can ubitbIt-block-read-4)) 
(paral Iel 

(ass i gn-vma-of f set d) 

(ca I I ~and-return-to ub i tb I t-b I ock-wr t te-4 

ub i tb 1 1- 1 ong-row-dest i nat i on-s I ow- 1 oop) ) ) 
(goto ubi tbi t-long-row-dest inat ion-slow-loop) )) ) 

(defucode ubi tbi t- I cng-row-dest inat ion-slow- loop :5 cycles per word (bus interference) 
(parallel-wi th-d-access-check-wri te bb-rf-offset 
(paral Iel 

(assign bb-width (- bb-width (b-constant 32.))) 

(trap-if (minus-f ixnuB obus) ubi tbi t- I ong-row-dest inat ton-done) ) ;aborts the assicn 
(para I Iel 

(lisp (trace-path ff/,)) 

(wa i t i ng-f or-mencry) 

(incr-d-of fsct) ) 
(paral Iel 

(store-word ( I ogxor bb-constant memory-data)) 

(jump ub i tb 1 1- I ong-row-des t i nat t on-s i ow- 1 oop) ) ) ) 

(defucode ub i tb ! ■. - 1 ong-row-des t i nat i on-done 
(if (pius-fixnum bb-width) 

(paral iel-wi th-d-access bb-d-offset 
(assign byte-s (1- bb-width)) 
(ass ion byte-r (a-constant 0)) 
(paral Iel-wi th-return 
(I isp (trace-path n/2)) 

(store-word (logxor (dpb bb-constant byte-s byte-r 0) »emory-data) ) ) ) 
(paral let ^ ^ » 

(t isp (trace-path tt/D) 
(return)))) 

(defmacro def-bi tb t t-block-read (name n) 
•(oefucode ,nafne 
(paral iel 

(assign a-block-size (b-constant ,n)) :Used later to advance offsets 

(assign b-btock-sire obus) 

(start-memory biock read)) :start first word 
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(paral lei 

(wai tinn-fcr-memoru) tuaitlng fcr first word 

{start-ffismcry blocK read)) ;8tart second word 

.•(loop for i from (- n-bi tb i t-buf fers n) below n-bi tbi t-buf fers 
coi iect * (abu3-3rrau-data 

(assign Ibi tbi t-buf fer ,i) 

(set-t'.'P3 (looxor bb-constant memory-data) dtp-fix)) 
,(seiectq (- n-bi tbi t-buf fcps r) 
(1 '(return)) 
(2 ni t) 
(otherwise ' (star t-iiemory block read))))))) 

(def-bi tbi t-block-read ubi tbt t-b t ock-read-8 8) ;I suppose this when interned... 
(dcf-bi tbi t-block-resd uoi tbi t-blccK-read-4 4) ;.,. wilt subsume this. 

(defmacro def-bi tbi t-block-wr i te (name n) 
' (defucode .name 

(act ivate-bi tbi t-buf fer) 

.•(loop for i from (- n-bi tbI t-buf fers n) below n-bi tbt t-buf fers 
col Iect * (paral iei 

(store-word (bi tbI t-buf fer ,i) block) 
(lisp (trace-path #/.)))) 
(paral lei 

(assign bb-d-offset <-#- bb-d-offset b-block-size) ) 
(c3l I deactivate-bitblt-buffer)) 
(paral iel-wr th-return 

(assign bb-width (- bb-width (rotate b-block-size 5))) ;2'^5 - bi ts-per-word 
))} 

(def-bi tbI t-biock-urite ubi tb! t-btock-wr i te-8 8) 
(def-bi tbt t-block-uri te ubi tbI t-block-wr i te-4 4) 

(defmacro def-d-a! igned-block-wr i te (name n) 
*(defucode .name 

(assign byte-s (1- bb-s-br tpos) ) 
(paral lei 

(ass ion bute-r (- (b-constant 32.1 bb-s-bi tpos) ) 
(cal TactTvate-bitb? t-buf fer) ) 
.•(locp for i from (- n-bi tbl t-buf fers n) below n-bi tbI t-buf fers 
append ' ( (parai lei 

(store-word (dpb (bi tbI t-buf fer ,i) bgte-s byte-r bb-s-word2) block) 
(I tsp (trace-path tt/.))) 
(assign bb-s-wcrd2 (rotate (bi tbI t-buf fcr ,i) byte-r)))) 
' (para! let 

(acsinn bb-d-offset (+ bb-d-offset b-b lock-si re)) 
(cal I'deact Ivate-bt tbi t-buf fer) ) 
(paral lei -wi th-return 

(assign bb-width (- bb-width (rotate b-block-sizo 5))) :2'^ • bi ts-per-word 
))) 

(def-d-a! ioned-b I ock-wr i te ubi tbI t-d-al igned-block-ur i te-S 8. ) 
(def-d-a I I gned-bi ock-wr i te ubi tbi t-d-al igned-b( ock-wr i tc-4 4. ) 

;;alu depends on neither source ncr destination bits 
(defucode ubi tbI t-long-rou-nei ther 
(if (plus-f ixnum bb-d-bitpcs) 
(sequential 

(assign b-temp (32- bb-d-bi tpoc) ) 
(paral le I -wi th-d-access bb-d-of f set 
(assign byte-r bb-d-bitpos) 
(assign byte-s (1- b-lprp) > 

(store-word tcpb bb-constant byte-s byte-r memory-data))) 
( incr-d-of f set) 

(assinn bb-width (- bb-width b-temp)) 
(paraTlo! 

(assign bb-d-bitpos (b-constant 8)) 
(i isp (trace-path #/b)) 
(jump ubi tbI t-iong-row-nel ther-loop) ) ) 
(paral lei 

(lisp (trace-path ^/a) ) 

(juKp ubi tbI t- long-rou-nei ther- loop) ) ) ) 

(defucode ub r tb 1 1- 1 ong-rou-ne i ther- I oop 

(if (greater-or-equal-f ixnum bo-uidth (b-constant (* 8, 32.))) 
(sequent ta) 
(parai Jel 

(asGign-vir.a-of f cet d) 
(cal 1 stcrr-biccK-bb-constant-S)) 
(assign bb-d-offset (+ bb-d-offset (b-constant 8.))) 
(paral lei 

lassign bb-width (- bb-width (b-constant (« 8. 32.)))) 
(jump ubi tbi t- iong-row-nei ther- loop) ) ) 
(sequential 

(dispatch-after-next (parallel (assion b-bfock-size (Idb bb-uidth 3 5)) 

(Idb bb-width 3 5)) 
((/) (parallel (assign-v»a-of fset d) 

(cal !-and-return-to 8tore-biock-bb-constant-7 

ub i tb t t- i ong-row-ne i ther-f i n i eh) ) ) 
((B) (parai tel (assign-vma-of f set d) 

(caM-and-return-to store-b (ock-bb-constant-B 

ubi tbI t-Icng-row-nei thcr-f inish) ) ) 
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((5) (parallel (as3ign-vma-of tset d) 

(cal !-3nd-return-to 8tore-block-bb-constant-5 
^,,^ , ubi tbi t-long-pow-nei thep-f Inish))) 

((4) (parallel (assign-vma-of f set d) 

(cal 1-and-return-to store-blocK-bb-constant-A 

ub i tb / 1- ! ong-row-ne i ther-f i n i sh) ) ) 
{(3) (parallel (asslcn-vr.a-of fset d) 

(cai i-and-return-to store-biocK-bb-constant-3 

ub i tb 1 1- 1 ong-row-ne i ther-f i n t sh) ) ) 
1(2) (parallel (ass icn-vma-cf fset d) 

(cal I-and-return-to store-block-bb-constant-2 
,,,, , ubi tb It- I ong-row-ne i ther-f inish))) 

((1) (assign-vma-of fset d) 
(parallel 

(lisp (trace-path tf/,)) 
(store-uord bb-constant) 
(jump ubi tbi t-long-row-nei ther-f inish) }) ) 
(para I lei 

(take-dispatch) 

(trap-if (zero-fixnum b-block-sire) ubi tb I t-long-pow-nei ther-f inish) ))) ) 

(defucode ubi tb! t-!ong-rc:-i-nei ther-f ini sh 

(assign bb-d-offset (+ bb-d-offset b-btock-size) ) 
(assign tb-width (Icgand bb-uidth ib-constant fio37))) 
(if (plus-f ixnufr bo-widil.) 

(parcl !e;-ui th-d-access r:b-d-offset ■ 
(assign byte-r (a-constant 0)) 
(assign byte-s il- tp-width)) 
(paraT Id 

(I icp (trace-D3th ti/2)) 

(store-word idpb bb-constant byte-s byte-r menory-data) ) 
(peturn) ) ) 
(paral lei 

(t isp (trace-path #/!)) 
(return)))} 

(defmacro store-b locK-bb-constant-rout i nea (n) 
* (prcgn *conpi le 

,«(lcop with s - •'STGnE-E:LC:<-E3-C0NSTANT-vd" 
for i from n downto 1 
collect * (defucode ,(f intern s i) 
(paral iel 

(store-ncrd bb-constant block) 
(I isp (trace-path f^/,)) 
,(if (> i 1) 

• ( jump ,(fintern s (1- i))) 
•(return))))))) 



(s tore-biock-bb-co-.st an t-f-ou tines 8. ) 

;;aiu depends both source and destination bits 
(defucode ubi tb! t-long-row-both 
tparal iel 

(assign b-temp bb-d-bitpcs) 
(if (zero-f txnuffl bb-d-bitpos) 

(if (zero-f ixnum bb-s-bitpos) 

(goto ubi^tbl t-3l ioned-rou-both) 



(paral lel-ui th-a-access bt>-s-of fset 
; ; SS£SSSS5S5£S£5SS55S5£SSSS5SS. ssss 



; ; ddddddddddddddddddddddddddddddod. 
(assinn byte-r (o2- bb-s-bitpos)) 
(paral iel 

(assign bb-s-word (rotate memory-data byte-r)) 

(I isp (trace-path U/c)) 

(jump ubi tbI t-d-al igned-row-both)))) 
(if (equ3l-f ixnum bb-s-bitpos b-teirp) 
(sequential 

(paral iel-uith-s-access bb-s-offset 

; ; SS5SSSSSSSSSSSSSSS3ESS3SS3. ssssss 

; ; dddddddddddddddddddddddddd. dddddd 

(paral Iel 

(assign byte-r (32- bb-s-bitpos)) 
(assign b-temp obus) ) 

(assign bute-s (31- bb-s-bitpos)) 

(assign bb-s-«ord (iogxor bb-constant (Idb memopy-data byte-s bute-p) )) ) 
(assmn byte-r bb-s-bitposi y = "y^c njjj 

(paral iel 

(assign-vma-of fset d) 

: ; ssssssssssssssssssssssssss, ssssss 

; ; DDDDDDDDDDDDDDDDODDDDDDODD, dddd:id 

(cal I bb-bute-a/u-operat ion-dispatch)) 
;; First partial word stored, turn into aligned case 
(mcr-wpap-s-of fset) 
(incr-d-of fset) 

(assign bb-uidth (- bb-uidth b-temp)) 
(assian bb-s-bitpos (b-constant 0)) 
(paral lei 

(assign bb-d-bitpos (b-constant 8)) 

(I isp (trace-path #/b> ) 

( iufrp ubi tbI t-ai igned-row-t>oth) ) ) 
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(if (lesser-f ixnum bb-s-bitoos b-temp) 
(goto ub I tb! t-iong-row-both-9- longer) 
(goto ubi tb! t-long-row-both-9-9hoPter) ) ) ) ) ) 

(defucode ub i tb i t- I ong-rou-both-s- ! onger 
(assign b-temp (32- bb-d-bi tpos) ) 
(p2raTiel-ui tn-s-access bb-s-offset 

(assign byte-r (32- bb-s-bi tpos) ) 

(assign Dyte-9 (1- b-temp)) 

(ass i an bb-s-uord2 mer;:cry-data) ) 

• • ss5sS^S355SSSS35S?5S5SS3. • , 

I : " DDDODDDDDDDDDDDCDDDDdddddddddddd 

;. , b-temp ► 

(assign bb-9-word (loaxcp bb-constant (rotate bb-9-uord2 byte-p))) 

; ; «S£sS3SSSSS£SSS3SS£S5SSS 

(para I lei 

(assign byte-r bb-d-bitpos) 

(assign b-temp-2 bb-d-bitpos)) 
(papal lei 

(assign-vma-of fset d) 

; ;9SSSSS5S5SSSSSS555S5SSS9. S9SSSSS5 

; ; DDDDDDDDDDDjDDDDLjDD. dddddd:?dciddd 

(call bb-byte-alu-operat ion-dispatchH 
(incp-d-of f set) 

; {Remaining ape (32- (s.bi tpos+(32-d.bi tpos) ) ) - d.bi tpo9-8.bt tpo9 
;; <"— 32-d.bi tpo9 ► •-- s.bitpos— » 

; :££SS53SS£S5SSSSSS?35S995S. BSGSSS9S 

; ; ddddddoddddddddddddd. dddddddddddd 
(assian byte-p (- b-temp-2 bb-9-bl tpos) ) 
(as-sigf^ bb-s-bitp09 (+ bb-s-bitpos b-tenp)) 
(assign bb-s-word (rotate bb-9-uord2 byte-r)) 
(assign bb-uidth (- bb-width b-temp)) 
(pspsi lei 

(assign bb-d-bitpos (b-constant 0)) 

(I isp (tpace-path ^/d)) 

(jur.p ubi tbi t-d-al igned-pow-both) ) ) 

jNced two S uopds to do the first partial word 
(defucode ubi tbl t- long-row-both-s-shorter 

; ; SSSSS59S5FSS5S535SSSSS59.8SSSS550 

; ; dddddddddddddcidddddddddddddd. dddd 
(paP3l lel-wi th-s-access bb-s-offsct 

(assign byte-p (32- bb-s-bitpos)} 

(assign bute-s (31- bb-p-br tncs) ) 

; ; S3SSSSS3355SSSSSSSS3SSS5, s^ssssss 

; ; dddddddddddddddddddddddddddd. ddud 

(assign bb-s-t^ord (logxor bb-const2nt (Idb aetoory-tfata byte-s byte-r)))) 
( incp-upfcp-s-off set-ahead) 
;; 4 — ^ E.bi tpos-d.bi tpos 
; ; . . .3£SS| ssssssssssssssssssssssss. ssssssss 

dddd dddddddddddddddacddddddd.tiddd 
(pai-al le l-ui th-s-access bb-s-of f set-shead 

(assign byte-s (- bb-s-bitpos b-temp 1)) 

(assign byte-p (32- bb-s-bitpos)) 

(ass i en bb-e-word2 (Ioqxop bb-constant »iemoru-dat3) ) ) 
; ; . . . S5SS iSSS55£SSSSSSSSS£C3SS£SS5, ssssssss 
;; dddd dddddddddddddddddddddddd. ddcid 

(assign bb-s-wopd (dpb bb-s-wora2 byte-s byte-p bb-s-wopd) ) 
(assign byte-r bb-d-bitpos) 
(assign bute-s (31- bb-d-bi tpoe) ) 
; ; . .•ssrsTssssssssesssssssssssssss. S3S999SS 
;; DDDD DOODDDUDOXDDDDDDDODDDDD.dddd 
(pare I ie) 

(assion-vma-of fset d) 

(caJ I bb-byte-alu-operation-dicpatch) ) 
(incp-d-of feet) 

(assign bb-s-offeet bb-s-o Ff set-ahead) 
; : • * .££5ss5s I ssssssssssssssssssssssss. essssess 
;; dddd odddddddddddddddddddriidcid. dddd 
(assign byte-p (- b-temp bb-s-bitpos)) 
(assign bb-s-bitpos (- bb-s-bitpos b-tenp)) 
(assign b-teirp (32- bb-d-bitpos)) 

(assian bb-s-wopd (logxor (potate bb-s-wopd2 byte-r) bb-constant)) 
(assign bb-width (- bb-uidth b-temp)) 
(parallsi 

(assign bb-d-bitpos (b-con9t3nt 8)) 

(lisp (trace-path ;S^/e)) 

( juap ubi tbl t-d-ai igned-row-both) ) ) 

(defucode ubi tbl t-al igned-row-both 

(if (greater-or-equal-f ixnum bb-width (b-conetant (» 8. £2.))) 
;;Fetch a block of words into the buffer 
(sequential 

(assicjn b-temp (+ bb-s-offsct (b-constant 8.))) 
(if (Tesser-f ixnum bb-s-row- length b-tetnp) 
(goto ubi tbl t-al igned-row-bbth-s low- loop) 
(sequential 
(para I tel 
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(assign-vma-of feet s) 

(ca// ubitblt-block-read-S)) 
(para) lei 

(as«jgn-vma-cffset d) 

- K -*l"u'T?'^^T'^!r^^";^° ut)itbU-bfock-alu-S ubi tbi t-al igned-row-both)) ) ) ) 
;:rrcb with uhat 3 left. Too fcacf dfspatch blocks are exoensive. 
iif (greater-or-equal-f ixnufB bb-widtn (b-constant (* 4 32 ))) 
(sequent i a I 

(assiqn b-temp (+ bb-s-offset (b-constant 4.))) 
(if (Ies8er-f fxnum bb-a-row- length b-temp) 
(goto ubi tbi t-al igned-rou-toth-slow-loop) 
(sequential 
(para I )e{ 

(ass ir-n-vma-off»et 9} 
(ca I Tub i tb I t-b t oc>c-pcad-4} ) 
(paral te\ 

(3ssign-vma-of faet d) 
(cal l-and-peturn-to ubitbl t-block-alu-4 
/«« ♦* w *.. . * . . ^ ub i tb I t-a I i oned-row-both-s I ow- 1 ocp) ) ) ) ) 
(goto ub I tb 1 t-a 1 1 gned-pow-bo th-s I ow- 1 oop} T) ) w^^/ / ; i ; 

(defucode ubi tbI t-aligned-pow-both-slou-loop ;12 cycles pep wopd 
(parallel-uith-s-access bb-s-offset 14 cycles 

(trap-if (lessep-f ixnun bb-width (b-constant 32.1) 
ub t tb I t-a i i gned-pow-bo th-s I ow- 1 oop-done) 

(uai t mg-for-memoru) 

(assign bb-s-uord Tlogxop bb-constant Bjeroopu-data) ) ) 
(para i I e I • 1+3 rur 1 <>« 

(assign-vma-offset d) '^^"^ ^^'=*^® 

(call bb-uopd-alu-operat ion-dispatch)) 
assign bb-width (-bb-width (b-constant 32.))} ;1 cycle 

•"^^7V:?P-«-°^^=^t^ ;2 cyclei ^ 

Iparal lei ,1 rnri- 

(incr-d-offset) '^ ^^^'® 

(I isp (tP3ce-path ff/,)) 

ijutap ubi tb(t-al igned-row-both) ) ) 

(defucode ub i tb t t-a I i gned-row-both-s I ow- 1 oop-done 
(if (ptus-fixnum bb-width) 
(sequent iai 

iparal let-wi th-s-access bb-s-offset 
(assign byte-r (b-constant 8)) 
(assign byte-s (1- bb-width)) 

(assign bb-s-wopd (logxop bb-constant nemopy-data} ) ) 
Iparal lei 

(lisp (trace-path tf/2)) 
(assign-vma-of f set d) 

( iump bb-byte-a I u-opepat ion-dispatch))) • jcal ( 
(paral lel-with-peturn .jt-c»«» 

(i isp (tpace-path U/1))))) 

(defucode ubi tbI t-block-alu-8 

(dispatch-af ter-th(3 (Idb bb-alu-opcrat ion 4 0) 
(parallel 

(assign a-block-size (a-constant 8,))' 
(assign b-block-size (a-constsnt 8.)) 
,,, -, , . . (start-memory block read)) ;stapt ftpst uord 
(d 2) (no to ub.tblt-block-loaand-ii)) x*u -,x«u 

Mr §•! Taoto ubitblt-biock-andc2-S)) ; x*Zy ^x^^u 

S 9.) (QOto ubitblt-btock-logxcr-8)) x xor y. ^x xor u 

7 U Tgoto ubitblt-block-loqior-S)) x^yf^^V 

((13. 14.) (goto ubttblt-block-Iognand-8)})) ; -(*x«y) , ^(x*y) 

(defucode ubi tbl t-block-3iu-4 

(dispatch-after-this (Idb Db-aiu-operat ion 4 8) 
(paral lei 

(assign a-block-size (a-constant 4.)) 

assign b-blcck-size (a-constant 4.)) 
//I -,1 / X . (start-memory block read)) tstart first word 

1 2) (goto ub.tblt-block-Iogand-4)) x*u -Ix'u 

4 8. Too to ubitbtt-block-andc2-4)} x^Iu J^ltu 

G ?;) (goto ubitblt-block-(ooxor-4)) r^^P ^*Zx xor u 

y^'l JsotQ abitblt-block-ianicr-4)} x+y^^^V 

((13. 14.) (goto ubi tblt-b/ock-lognand-4)))} ; -^(^x*y) , ^(x*u) 

(defnacro def-block-aluop (name n alu) 

'"''rLnA?^!SMf?Li!::*^T°^''P^"?, n^'^i^ 'a'^J weird-alu-functions) 

:'/-.^f ^! simultaneously run ALU and stope into the bi tbI t-buf fer 
Idefucode .name 
(paral lei 

(waiting-for-memory) ? first wopd alpeady started 

(dectarp-memory-t iming act t ve-cycle) ) 

(loop for i from (- n-b i tb I t-buf fere n) below n-bi tbI t-buf fers 
col lect (sequential 

(abus-array-data 

(assign b-tenp (,alu (bi tbI t-buf fer ,i) nemopy-data) ) 
.tif T> (- n-bi tb! t-buf fers i) 1) ^ 

Mstart-memory block read))) ; start next word 
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(paral le! 

(assign (dI tb! t-buf fer ,») (aet-tupe b-terrp dtp-fix)) 
,(if I. (- n-bitbl t-buf fers i) D' 

Mjurp ,(fintern *'UBITELT-BLOC<-ALU-UPITE— d" n))))))) 
:; Nortr.a! case 
* (def ucode »nafne 
(parai lei 

(wai ting-for-mfffficry) ; first word already started 

(dec 1 are-memory- 1 imina act i ve-cycle) 

(start-memoru re3d block.}) ; start second ucrd 

,*{loop for i from (- n-bitbt t-buf fers n) below n-bi tol t-buf fers 
cot lect * (paral lei 

(abus-arrs'j-data 

(assign Ibi tbi t-buf fer ,i) (set-tgpe (,alu (bi tbi t-buf fer ,i) 

•emoru-data) 
dtp-fix))} 
.(selectq (- n-bi tbi t-buf fers i) 

(1 '(iump ,{fintern *'USITBLT-BLOC)C-ALU-UniTE-v d" n))) 

(2 nil) 

(otherwise •(start-memory block read))) ; start word after next 

(def-b!ock-aluop ubi tb! t-block-lonand-S 8 logand) 
(cef-blcck-aluop ubi tbi t-blcck-fogior-S 8 logior) 
(dcf-bicck-alucp ubi tbi t-biccK-iogxor-g S logxor) 
(def-biock-aluop ubi tb I t-btock-andc2-S 8 andcZ) 
(def-block-aluop ubi tblt-block-lognand-8 8 lognand) 

(def-block-aiuop ubi tbi t-block-Iogand-4 4 logand) 
(def-block-aluop ubi tol t-blcck-Iogior-4 4 logior) 
(def-o)ock-alucp ubi tbi t-b(Ock-logxor-4 4 logxor) 
(def-blcck-alucp ubi tbi t-block-andc2-4 4 andc2) 
(def-Dlock-alucp ubi tbi t-btock- lognsnd-4 4 lognand) 

(defrscro dcf-b ! ock-al u-ur i te (name n) 
Mderucoie ,name 
iparal lei 

(assign-vma-of f set d) 
tc2i I 'activote-b! tt I t-buf fer) ) 
.aiiocp for i from (- n-b i tb I t-buf fers n) below n-bi tbi t-buf fers 
col lect • (para! iel 

(Etcre-word (bi tbt t-buf fer , i) block) 
(lisp (trace-path <?/.)))) 
(paral ie I 

(assign bb-d-offset (+ bb-d-offset b-bfock-size) ) 
(call dcactivate-tai tb! t-buffer) ) 
(assion to-width (- bb-width (rotate b-block-size 5))) ;2^ - bi ts-per-uord 
\p2ra II e I 

(assign bh-s-offset (+ bb-s-offset b-block-s t ze) ) 
(return) ) j ) 

jdef-tlcck-alu-wri te ut) i tb t l-O I ock-a I u-ur i te-S 8) 
idef-t)iock-alu-;jr; te uD i tti I t-b t cck-a I u-ur i te-4 4) 

Each tine through the loop, »-uord was fetched from memory like 

•• 5. b i tpos ► 

ssssssssss 

and then rotated so it looks tike 
ssssssssss 

^ 5. 5 i tpos * 

Each tine, another 8-wcrd2 gets fetched and deposited into s-uord tike 
!♦• s.bi tpos » 

2222222222 222Z222222222222Z22222 

The rotation for the dpb equals the rotation for setup for next loop. 

bb-s-wcrd has the partial previous source word whose address is in bb-s-offset, 
rotated into angnment with the destination, but not xored with bb-constant 
defucode ubi tbi l-d-a) /gned-row-both 
(if (greater-or-equal-f ixnum bo-width lb-constant (* 8. 32.))) 
;;Fetch a block of words into the buffer 
(sequent iat 

(assign b-temp (+ bb-s-offset (b-constant 8-))) 
{if (Tesser-or-equai-f ixnua bb-s-row- length b-temp) 
(goto ubi tbi t-d-al igned-rcw-both-sJow-loop) 
(sequential 
(paral )ei 

(assign-vma-of fset s I) 
(ca( \ ubi tbi t-rotated-block-read-8) ) 
(paral le! 

(assign-vma-of fsct d) 

(cat !-and-return-to ubi tbi t-block-alu-S ubi tbi t-d-at igned-row-both) ) ) ) ) 
;;Frob with what s left. Too bad dispatch blocks are exoensive. 
(if (greater-or-equ3l-f ixnum bb-width (b-constant (» 4 32.))) 
(sequential 

(ass ion b-temp (+ bb-s-offset (b-constant 4,))) 
(tf (lesser-or-equal-f ixnum bb-s-row-length b-temp) 
(goto ubi tDl t-d-at igned-row-both-s low- loop) 
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(seauentiat 
(paral lei 

(assinn-vma-of f set s 1) 
<ca I i 'uD i tb I t-po tated-b I ock-pead-4) ) 
(paral lei 

(assign-vma-of f set d)' 

(cal l-and-return-to ubi tbi t-block-aiu-4 

ub f tb I t-d-a I i qned-rou-both-s 1 ow- 1 oop) ) ) ) ) 
(goto ubitblt-d-al jgned-rou-botn-slou-Iocp)?} J 



(defLtcode ubi tb I t-d-a I igned-rou-both-siou-toop 
( inrr-urop-s-of fset-ariead) 
(paral lei-wi th-s-access bb-s-off set-ahead 

(trap-if Ocsser-f ixnum bb-uidth (b-constant 32.)) 
ub i tb I t-d-a I i aned-pow-both-done) 

(assign bute-s (1- fcb-i-bi tpos) ) 

(«ssir;n bb-s-uopd2 memory-data)) 
(atsign byte-r (32- bb-s-bi tpcs) ) ;1 

(arsign bb-s-word (dpo bb-s-uord2 bute-s byte-p bb-s-wopd)) 
(ass ran bb-s-uord ( I ogxor bb-constant-a bb-s-uord) ) 



17 cycles pep u-ord 
2 



(oaraTlet 

(assign-vma-of f set d) 

(ca I r bb-uord-a ! u-opepat i on-d i spatch) ) 
assign bb-uidth (- bb-width (b-constant 32.))) 
(tncp-d-of fset) 

(assign bb-s-offset bb-s-of f set-aiisad) 
(parallel 

(assign bb-s-word (rotate bb-s-uopd2 byte-p)) 

(lisp (tpace-path U/.n 

( jump ubi tbI t-d-ai icned-row-both) ) ) 

At entpy, we have e-uord fetched from tnemopy like 

* s.bi tpoi ► 

sssssssses 

but thsn potated co it looks like 

scssssssss 

•- s.bi tpos » 



;l+3 



;1 

:1 



This IS to be combined with d-uopd which looks like 

• • • ddddddd Jdddd 

, . ^ < width * 

(Qcfucode ubitblt-d-al igned-pow-both-dons 

asEtgn bb-s-wopd (Iccxop bb-constant-a bb-s-uopd)) 
UT (plus-fixnum bb-w»dth) 
(sequent i al 

(assicn b-temp (32- bfc-s-bi tpos) ) 
(if (Ies£cr-cr-equ3l-f ixnum bb-uidth b-temp) 
;;we have enourjh s bits 
; ;* s.bi tpos — -*4 a. temp -♦ 

'• SSS3 5SC53CSSS23 

• » dddduddcidddd 

V •- width — t 

(sequent lal 

(assign byte-r (b-constant 8)) 
(assign byte-s (1- bb-uidth)) 
(para! let 

(assign-vma-of fset d) 
(» isp (trace-path tf/U)) 

(jump bb-byte-alu-operat ion-dispatch))) ;jcall 
;;need to ^et anothep coupce uopd 

; ;. s.bi tpos M- a. temp ► 

:; ttsssssscsssssss 

; ; dddddddddCd'Ciiddddddd 

;; < —width > 

(sequential 

(paral lel-ui th-5-access bb-s-of fset-ahsad 
(assign byte-r b-terrp) 
(assign byte-a (I- bb-s-bi tpos) ) 

(assign bb-s-wcpd2 (logxop memopy-data bb-constant) ) ) 
(assign bb-s-wopd (dpb bb-s-uopd2 byte-s byte-p bb-i-«opd) ) 
(assign byte-p (b-constant 0)) 
(assicn buxe-G (1- bb-width)) 
(papallel 

(assion-vma-of f set d) 
(i isp"'(tpace-path U/S)) 

( jump bb-byte-alu-opepation-dispatch)))) ) ticall 

(paral lel-w( th-peturn 

(I isp (trace-path U/3})))) 

;bb-s-wopd has the ppevious soupce wcpd, potated but not xoped with bb-ccnstant 
;J cycles per word seems to be the best I can do (can't rotate white stoping in bi tbI t-buf fep) 
:ft bb-s-wopd was xoped alpeady, it would take 4 cycles pep word here 
(defs^acpo def-bi tbI t-potated-block-pead (name n) 
(defucode .name 

(assign byte-s (1- bb-s-bi tpos) ) 
(papallel 

(assign a-block-size (b-constant ,n)) ;Used latep to advance offsets 

(assign b-b lock-size obus) 

(stapt-memopy biock read)) ;8tart fipst uopd 
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(paral lei 

(wai ting-for-mcfrory) jwaiting for first word 

(assign byte-p (32- bo-s-bi tpcs) ) ) 
.•(loop for i from (- n-bi tb I t-buf fers n) betou n-bi tb t t-buf fers 
append * { (abus-array-data 

(assign bb-5-uord2 (dpb aemory-data byte-a byte-r bb-s-word) ) ) 
(parai !el 

(declare-memory-t iming data-cycle) ;nO holds 
(assign bb-s-word (rotate nemory-data byte-r)) 
.(and (> (- n-bi tb! t-buf fers i) 1) 
•(start-memory blocK read))) 
(parai iei 

(assign (bi tb! t-fcuf fer ,i) 

(set-tuoe (logxor bb-constant bb-s-word2) dtp-fix)) 
,{if {m (- n-bi tbit-buffers i) 1) 
Mretuf^n) ))}))) 

(def-bi tbi t-rotated-block-resd ubi tb I t-rotated-block-rc?--S 8) 
(def-bi tbi t-rolated-blocK-read ubi tbi t-rotated-block-read-4 4) 

(defucode utoi tb I t-long-row-source-bacKwordo 
(paral lei 

(assign b-tenp bb-d-bi tDos) 
(if (rerc-f ixnur? bb-d-bitpos) 

(if (zero-f ixnuta bb-s-bitpos) 
(para) lei 

(ascion bb-s-offset (1+ bb-s-of f set) ) ;tho loop will deer first, before pclsr 
(I icp' (trace-path U/a)) 

( ju-p ubi tbI t-al igned-rou-sourcc-backuardo) ) 
(sequential 

IpGral lel-ui th-s-access bb-s-offset 
(ossion byte-r (32- bb-a-bi tpos) ) 
(paral (e! 

(assign bb-s-uord (fcnxor bb-constant (rotate memory-data byte-r))) 
(lisp (trace-path iV/cI) 

( jump ub i tb I t-d-a I i gned-ron-source-backu3rds) )1 ) ) 
(if (equal -f ixnum b-temp bb-s-bitpos) 
(sequent iai 

(paral le l-wi th-s-acces3 bb-s-offset 
(assign byte-s (1- bb-s-bt tpos) ) 

(assign bfc-s-word (logxor iiemcry-data bb-constant))) 
(parai lel-wi th-d-access-check-wr i te bb-d-of f set 
(decr-d-of fset ) 
ipara] lel 

(assign bute-r (b-constant 0)) 
(assign bb-s-bi tpos (b-constant C))) 
(store-word (dpb bb-s-uord byte-s byte-r nemory-data) ) ) 
;; Now we can turn into the aligned case 
(assign bb-width (- bb-width b-temp)) 
(paralJel 

(assign bb-d-bitpos (b-constant 0)) 
(I isp (trace-path tf/t^)) 

(jump ubi tb! t-al igned-row-source-backwards) ) ) 
(if (greater-f ixnum bb-s-bitpos b-temp) ; s > d, enough in the current word 
(sequent iaI 

(paral lel-wi th-s-access bb-s-offset 
(assign byte-s (1- bb-d-bitpos)) 
(assinn byte-r (- b-temp bb-s-bi tpoc) ) 
(assign bb-s-word (logxor bb-constant memory-data))) 
(para i le I -wi th-d»acc2ss-check-wr i te bb-d-of f set 
(assign bb-s-bitpos (- bb-s-bitpos b-temp)) 
(assign bb-d-bitpos (b-constsnt 0)) 

(store-word (Idb bb-s-word byte-s byte-r memory-data))) 
(assign bb-s-word (rotate bb-s-word byte-r)) 
(ass ton bb-width (- bb-width b-temp)) 
(paral tei 

(decr-d-offset) 
(I isp (trace-path ff/d) ) 

( jurip ubi tbt t-d-a I igned-row-source-backwards) ) ) 
(sequential ;s < d, need to fetch another word 

(paral le!-wt th-8-access bb-s-offset 
(paral tel 

(assign byte-r (- b-temp bb-s-bitpos)) 
(ascign a-temp (- b-temp bb-s-bitpos))) 
(assign byte-s (1- a-temp)) 

(assign bb-s-word (logxor bb-constant (rotate aemory-data byte-r)})) 
(dccr-t.TCp-s-off set-ahead) 
(parai lel-wi th-s-access bb-s-of f set-2h«ad 

(assign tb-s-uord2 (logxor bb-constant memory-data))) 
(ass inn bb-s-uord (Idb bb-s-word2 byte-s byte-r bb-s-word)) 
(paral lel-wi th-d-3ccess bb-d-of f set 
(assign byte-r (b-constant 0)) 
(assign byte-s (1- bb-d-bitpos)) 

(store-ucrd (Ido bb-s-word byte-s byte-r «cmory-data) ) ) 
(assign bb-s-bitpos (32- a-temp)) 
(assign byte-r a-temp) 

(assign bb-s-word (rotate bb-5-word2 byte-r)) 
(assign bb-s-offset bb-s-off set-ahead) 
(assign bb-width {- bb-width b-temp)) 
(ass ion bb-d-bitpos (b-constant O) 
(paral tel 
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(decr-d-of fset) 

(I i£p (trace-psth n/e)) 

( junp ub i tb I t-d-a I i gned-row-cource-tackwards) ))))))) 

;bb-s-offset is 1+ the ''rear value at this point 
(defucode ubi tbi t-a! iqned-rou-souPce-bacKwards ;9 cycics per uord 
(decr-wrap-s-of f set; ;1 

tparai te!-wi th-9-access bb-s-offset ;4 

(trap- if ( Icsser-f iKnum bb-width (b-constant 32,)) 
ub i tb I t-a I i gned-row-source-backwards-d6ne) 

twat t ing-f or-memoru) 

(assign bb-s-word 1 1 ogxor bb-constant wemory-data) ) ) 
(ass ign-vna-of f set d) ;1 

(store-ucrd bD-s-uord) :1 

(assfcn bb-uidth 1- bb-uidth (b-constant 32.))) ;1 
(parallb! ;1 

idecr-d-offset) 

It isp (trace-path U/ ,)) 

( junp ub i tb 1 t-a I I gned-row-source-backuards) ) ) 

(defucode ub i tb ! t-a t i gned-row-soLfrce-backwards-done 
(if (plus-fixnum bb-width) 
(sequential 



(para 
(ass 
(ass 
(ass 

(para I 



lel-ut th-s-access bb-s-offset 
ign byte-s (1- bb-uidth)) 
ign byte-r bb-width) 

ign bb-s-uord (iogxop bb-constant (Idb necory-data byte-s byte-r)))) 
^_ _ lel-ui th-d-access bb-d-offset 
(assign byte-r (32- bb-width) ) 
(paraT tet-wi th-retum 

(store-word (dpb bb-s-word byte-e byte-r nemory-data) ) 
(iisp (trace-path #/2M>); 
(para! lel-wi th-return 

(lisp (trace-path ^/l))))) 

;;each time through the loop, bb-s-uord has the leu part of the previous word 
;; rotated to be at the high ^n:i of the word. Ue use it as background to LD3 the 
;;high part of the next word into \t* 

;bb-s-offset is 1+ the "real" value at this point 
;could bum one cycle bu moving assignment to byte-s out of loop, 
:but this should use block mode anyway 

(defucode ubi tbi t-d-at i gned-row-source-backuards ;ll cycles per word 
(cccr-wrop-s-of f set) ;1 

(parai le!-wi th-s-3ccess bb-s-offset ;4 

(trap- if ( !esser-f ixnum bb-width (b-constant 32.)) 

ubi tbI t-d-a I i gned-row-source-backuards-donc) 
(assign byte-r (32- bb-s-bl tpos) ) 

(assign bb-s-word2 (logxor bb-constant memory-data))) 
(assign byte-s (31- bb-s-bi tpos) ) ;1 

(assign-vma-of f set d) ;1 

(stcre-wcrd (Idb bb-s-word2 bgte-s bgte-r bb-s-word)) ;1 
(assign bb-uidth (- bb-uidth (b-ccnstant 32.))) ;1 
(decr-d-offset) ;1 

(psrai lei •! 

(assign bb-s-word (rotate bb-s-uord2 bute-r)) 
(I isp (trace-path #/.)) 
(jump ub i tb I t-d-a i t gned-rou-source-backwards) ) ) 

(defucode ub i tb t t-d-a I i gned-row-source-backuards-done 
(parol lei 

(assign bb-width-b bb-width) 
(if (plus-fixnum bb-uidth) 

(if (greater-or-equal-f ixnura bb-s-bi tpos bb-uidth-b) 
(para I iel-ui th-d-access bb-d-offset 
(assign byte-r (b-constsnt 8)) 
(ass i an byte-s (31- bb-width)) 
(paral le (-wi th-return 

(store-uord (Idb memory-data byte-s byte-r bb-s-word)) 
(lisp (trace-path U/k)))) 
(sequent ia t 

(paral lal-wi th-s-access bb-s-offset 
(assign byte-r bb-width) 

(assign bb-s-word (rotate bb-s-word byte-r)) 
(assign bb-s-word2 (logxor bb-constant memory-data))) 
(paral lei 

(assign byte-r (- bb-width-b bb-9-bi tpos) ) 
(assign a-ter;;p obus) ) 
(assign byts-s (1- a-temp)) 

(ass i on bb-s-uord (Idb bb-s-word2 byte-s byte-r bb-»-word)) 
(paral lel-wi th-d-access bn-d-of f set 
(assign byte-s (1- bb-uidth)) 
(assign byte-r (32- bb-width)) 
(paral lel-with-return 

(store-word (dpb bb-s-word byte-s bute-r memory-data)) 
(lisp (trace-path U/S)))))) 
(paral iel-wi th-return 

(I isp (trace-path U/2)))))) 
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(defucode ubi tb) t- iong-pow-both-backuards 
(parai lei , 

(assign b-temp bb-d-bitpos) 
(i-f (zero-fixnum bb-d-bitpos) 

(if (zero-f ixnuiii bb-9-bitpos) 

^tafsign bb-9-offset (1+ bb-5-of f set) ) ; loop wilt deer first before pel sr 

(( isD (trace-path tf/a)) 

{ jur.p ubi tb I t-al igned-rou-both-backwards) ) 
(paral te l-ui th-s-access bb-s-of fset 
(assign byte-r (32- bb-s-bi tpos) ) 

(parallel ... 

(assign bb-s-uopd (looxor bb-constant (rotate renory-data byte-r))) 
Uisp (trace-path tf/cl) 

U'jco ubitbit-d-3l igned-rou-both-backuards))}) 
(if (equal -f (xnutr b-teirp bb-s-bitpos) 
(sequential 
(para! le l-ui th-s-access bb-s-of fset 
(assign bute-s (1- bb-s-bitpos)) 
(assign byte-r (b-consl';-.t 8)) 

(assign bb-s-uord (logxor bb-constant memory-data))) 
(paral lei 

(ass ign-v«a-of fset d) 
(call bb-bute-alu-operat ion-dispatch)) 
(assign bb-width (- bb-width b-temp)) 
(ass f on bb-s-bitpos (b-constant 0)) 
(ass i en bb-d-bitpos (b-constant 8)) 
{parallel 

(decr-d-offset) 
fticp (trace-path #/b) ) 

(ju:np ubitbl t-at igned-rou-both-backwards))) 
(if (nreater-f ixnum bb-s-bitpos b-tcmp) ;8 > d, enough in first word 
(sequent iai 

(paral !ei-wi th-s-access bb-s-of fset 
(parai le! 

(assign byts-r (- b-temp bb-s-bitpos)) 
(assign a-temp obus)) ;thi8 is negative 
(assinn byta-s ii- bb-d-bitpos)) 

(ass ion bb-s-wcrd (logxor bb-constant (rotate meiaory-data byte-r)))) 
(assign'byte-r (b-constant B) ) 
{parallel 

(assion-vma-of fset d) 
(cal I " Db-byte-a I u-operat ion-dispatch) ) 
(assign bb-s-bitpos (- bb-s-bitpos b-temp)) 
(assign bb-d-bitpos (b-constant 8)) 
(assibn bb-uidth (- bb-uidth b-temp)) 
(paral lei 

(decr-d-of f set) 
(I isp (trace-path #/d)) 

( jumo ub i tb 1 t-d-a I i gncd-rou-both-backwards) ) ) 
(sequential !»<d, need to fetch another word 

Iparal te!-ut th-s-access bb-s-of fset 
(assign byte-r (- b-temp bb-s-bitpos)) 

(ass i an bb-s-uord Oogxor bb-constant (rotate »emory-data byte-r)))) 
- (dccr-urap-s-of fset-ahead) 
iparallel-ui th-s-access bb-s-of fset-ahead 
(assign a-temp (- b-temp bb-s-bitpos)) 
(assign byte-s (1- a-temp)) 

(ass i en bb-s-word2 (logxor bb-constant memory-data))) 
(assign"bb-s-uord (Idb bb-s-word2 byte-s byte-r bb-s-word)) 
(assign byte-s (1- bb-d-bitpos)) 
(assign byte-r <b-constant 9i ) 
(paral lei 

(assian-vmarof f set d) 
(cal l"bb-byte-alu-opcrat ion-dispatch)) 
(parallel 

(assign a-temp (- b-temp bb-s-bitpos)) 
(assign byte-r obus) ) 
(assign bb-s-uord (rotate bb-s-uord2 byte-r)) 
(assign bb-s-bitpos (32- a-temp)) 
(assion bb-s-offset tb-s-of fset-ahead) 
(assign bb-d-bitpos (b-constant 8)) 
(assian bb-width (- bb-width b-temp)) 
(paral lei 

(decr-d-of fset) 

(lisp (trcce-path tt/e)) 

(jump ubi tbi t-d-a i igned-row-both-backwards) ) )))))) 

5bb-s-offset is 1+ its 'raaf vaJue 

(defucode ubi tbI t-ai ioncd-row-both-backvierds :ll cycles per word 
(decr-wrap-s-of fset) :1 

(para! lel-ui th-s-access bb-s-of feet i^ 

(trap-if ( lesser-fixnun*. bb-width (b-constant 32. U 

Ubi tbI t-al igned-row-both-backuard^i-tons^ 
(wai t ing-for-memoru) 

(assign bb-s-word Ilogxor bb-constant wemory-data) ) ) 
(paral lei ;l+3 

(assign-vma-cf f set d) 
(cat I bb-word-a! u-cperat i on-dispatch) ) 
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(assign fcb-utdth (- bD-uidth lo-constant 32.))) ;1 
(paraliel ',1 

idecr-d-of f set) 

( i isp itrace-p2th tf/ J ) 

( jur.p ubi tot t-ai igned-row-both-backwards) ) ) 

(def ucode ub ! tb I t-a I i rtned-rou-both-backuards-done 
(if (p i us-f ) xnum bb-w i dth) 
(sequent i a I 

(paral lei -ui th-s-access bb-s-cffset 
(assign byte-s (1- bb-width)) 
(assign byte-p bb-utdth) 

lacsign bo-s-ucrd (logxcr bb-constant (Idb «enjory-data byte-s byte-r)))) 
(assign byte-r (32- bb-width)) 
(parallel 

(assign-vma-of f set d) 
( t isp {tr?ce-p3tf-( nicS ) 

(iufrp bb-bute-alu-operat ion-dispatch) )> ;jcall 
(paral lel-ui tn-return 

(i isp (trace-path ^/l))))) 

F:>1mach>ucode>nBITBLT,LISP.22 



;bb-s-offset is 1+ its "real" value 
;bb-s-uord has the previous uord, rotated and xored 
(defucode ubi tb! t-d-al ign«d-rou-both-bacKuapds ;14 cucies per word 
(decr-urap-s-of fset) ;1 cycles 

(parat lel-ui th-s-access bb-s-offset ;4 cuclcs 

(trap- if ( lesser- fixnuni bb-utdth (b-constant 32, T) 
ubi tbi t-d-al igned-row-both-bacKwards-done) 

(assion bute-r (32- bb-s-bi tpos) ) 

(assign bb-s-word2 (fogxor bb-constant wemopy-data) ) 3 
(asstgn"'byte-s (31- bb-s~bi tpos) ) :1 

(assign bb-s-uord (idb bb-5-uord2 byte-s byte-p bb-s-ucrd)) ;1 cycle 
(paraTlel ;l+3 cycles 

(ass ign-vBia-of f set d) 

(cal 1 bb-uDPd-alu-opeP3t ion-dispatch) ) 
(assign bb-s-word (rotate bb-s-uopd2 byte-r)) :1 
(assian bb-uidth (- bb-width (b-constant 32*))) ;1 
(parallel 

(decr-d-offset) ;1 

(I isp (trace-path */.)) 

C jump ub i tb 1 t-d-a I i gned-rcu-both-backuards) ) ) 

(defucode ubi tb! t-d-al igned-rou-both-bacKwards-done 
iparal le I 

(assign bb-width-b bb-width) 
(if (plus-fixnum bb-uidth) 

(if (gpeater-or*equ3l -f ixnuB bb-s-bitpos bb-width-b) 
(seqaenT^af 

(assign by-te-r bb-w j dth) 

(assign bb-s~uord (rotate bb-s-uord byte-r)) 

(assign byte-s (1- bb-uidth)) 

(asslcn &ute-r (32- bb-width)) 

(paraTlel 

(assign-vma-of f set d) 
(I isp I trace-path )tf/4)) 

(jutrp bb-byte-alu-operat ton-dispatch) ) ) ;jcaM 
(sequent t 3/ 

(poraHel-wt th-s-access bb-s-offset 
Cassign byte-r bb-uidth) 

(assign bb-s-«ord ^rotate bb-s-word byte-p)) 
(assign bb-s-wopd2 (logxop bb-constant mcT.opy-data) ) ) 
(paral lei 

(assign bute-r (- bb-width-b bb-s-bitpos)) 
(assign a-tenp obus) ) 
(assign byte-s (1- a-temp)) 

(assian bb-s-word (Idb bb-s-word2 bytc-s byte-r bb-s-uord)) 
(assign byte-s (1- bb-uidth)) 
(assicn byte-p (32- bb-width)) 
(pcraTlel 

(assign-vma-of tset d) 
(I isp (trace-path ^/5)) 

(jump bb-bute-aiu-operation-dispatch) ) )) tjcall 

(paral le l-u I th-return 

(I isp (trace-path #/3)))))) 

code for Wecode-bi tbI t-arrays 

Take alu fpom-arrcy to-appay' 

Retupn (s-beg-acJdr s-beg-bttpos s-row-iength s-height s-bi ts-per-el t 

d-beg-addr d-beg-bitpos d-rou-lenglh d-height d-bi ts-per-el t 

arrsy-reg-event-count) 
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:aros 



(defatofflicro bbd-alu (aTren (stack-pointer -2))) 
(detatotr.icro bbd-s-array (anen (stack-pointer -1))) 
tdefatontcro bbd-d-array top-of-stack-a) 

;; 4 slots for arratj-setup-2d to return tts results 
idefatomicro bbd-control (ameni (stack-pointer 1 ) )) 
(defatcmicro bbd-Dase-pointer (amem (stack-pointer 2))) 
(defatomicro bbd-uidth (amem (stack-pointer 3))) 
(defatomicro bbd-height (amem . (stack-pointer 4))) 



(defa 
(defa 
(defa 
(defa 
(defa 
(defa 
(defa 
(defa 
(defa 
(defa 
(defa 



tomicro 
tofflicro 
tomicro 
tcmicro 
towicro 
tonicro 
tcitiicro 
tomicro 
tomicro 
tomicro 
tomicro 



bbd-s- 

bbd-s 

bDd-5 

bbd-8-i 

bbd-G 

bbd-d-! 

bbd-d- 

bbd-d- 

bbd-d 

bbd-d- 

bbd-ev 



beg-addr 

beg-oi tpcs 

row- length 

height 

bt ts-per-el t 

beg-addr 

beij-bi tpos 

row- length 

height 

bi t5-per-e\ t 

ent-count 



(amer^ 
(amem 
(ameni 
(amem 
(amem 
(amem 
(amem 
(atrcm 
(arrtem 
(amem 
(aoem 



(stack- 
(stack- 
(stack- 
(stack- 
(stack- 
(stack- 
(stack- 
(stack- 
(stack- 
(stack- 
(stack- 



(def atom i crc bb-a I u-depends-on-source 

(b-constant ^'^ (ioop for alu in 



■pointer 
•pointer 
pointer 
•pointer 
■pointer 
■pointer 
pointer 
pointer 
■pointer 
pointer 
■pointer 



( 5 19. 
;3 12. 
:8 15, 



5))) 
6))) 
7))) 
8))) 
9,)) 
18.) 
11.) 
12.) 
13.) 
14.) 
15.) 



: source 
;dest 
:nei thcr 



i 2 4*6 7 h. 9, 11. 13, 14. 

} 



;both 



sum (ach 1 alu)) )) 

(defmicro compute-beg-bi tpos (for-what) 
(tet ((beg-bitpos Tsetectq for-what 

(s 'Cbd-s-beg-b! tnos) 
(d 'bbd-d-beg-bi tpos) 

(otheruise (ferrcr "What is -^S" for-what)))) 
(rcu-icngth (selectq fcr-uhat 

(s 'bbd-s-row-length) 
(d 'bbd-d-rou- length) 

(otherwise iferror "What is -^S" for-uhat) ) ) ) ) 
•(sequential 

(assign b-lou-di vidend tcp-of-stack) 
(assicn a-posi t ive-di vi sor bbd-uidth) 
(paral iel 

(assicn b-high-di vidend (a-constant 0)) 
(assign a-di vide-step-count (b-constant 15,))) 
(paral iel 

(assicn a-negat ive-di vi sor (- a-posi tive-di visor) ) 
(cal I "di vide-sucrout ine) ) 
;; bits per elt eetup correctly in byte-r 

(assign , beg-bitpos (cet-tupe (rotate b-hiqh-di vidend bute-r) dtp-fix)) 
(assign b-temp (set-tupe (Idb , row-length 27. 5 G) dtp-fix)) 
(assign bb-a-temp b-te:np) 
(mpy-32-22 bb-a-tcmp b- tow-dividend set-b-temp fcr-cffect nil)))) 

(defmicro set-b-teirp (x) 
• (assign b-tcnp ,x) ) 

(definst Xbi tbi t-decode-arrays no-operand 
:;See whether the alu operation depends on the source a-'ray 
(assign byte-r (32- bbc'-alu)) 
(parallel 

(assign t:?p-of-stack (a-constant C) ) ; the "subscript" 
(if (Tdb-bi t-tect bb-alu-^epends-on-source byte-r) 
(sequent la I 
(paral lei 

(check-arg-type array bbd-s-array dtp-array) 
(assign vma btd-o-array) 
(assign b-vtr.a bbd-s-array) 
(call arrau-setup-2d)) 
(parallel (as-sign b-tenp bbd-controt) 

(cal I bbd-bi ts-p'jr-el t)) 
(parallel (assign bbd-s-bi ts-per-el t (set-type b-temp dtp-fix)) 

(assign byte-r b-tctrp)) 
(assign bbd-s-row- length (cet-type (rotate bbd-uidth byte-r) dtp-fix)) 
(cofTpute-beg-bi tpos sJ 

(ascign tbd-s-bcg-3d:'Jr (-t- bbd-base-potnter b-tenp)) 
(assign bbd-s-height bbd-heicjht) ) 
iceq'jcnt lal 

(assign bbd-E-bi ts-per-el t (cet-tyoe (a-con^tant 1) dtp-fix)) 
(ass)cn bbci-s-rou- length (set-type (a-con^tant 1G23D80J dtp-fix)) 
(assign bbd-s-beg-hi tpos (set-tuco (a-ccnslant 0) dtp-fix)) 
(assinn br:d-s-tsg-ad:ir quote-nil) 

(assicn t't:d-s-hejoht (set-tyoe (a-constant ICOCCSS) dtp-fix))))) 
' decode the dcDt i nat i on nrray 



(assign top-of-etack (b-constant 0) ) 



(paraT)e 



;the "subscript 



(check-arg-type array bbd-d-array dtp-arrau) 
(assign vma L'bd-d-array) ^ r- « 
(assign b-v«a bbd-d-array) 
(cal I array-setuD-2d)) 
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(parallel (assign b-temp bbd-control) 

(assign t5bd-event-count bbd-control) 
(cal i bbd-bi ts-per-el t)) 
(parallel (assign bbd-d-bi ts-per-el t (set-type b-temp dtp-fix}) 

(assiqn tyte-r b-tecp)) 
(assign bbd-d-rou-lenqth (set-type (rotate bbd-width Dyte-r) dtp-fix)) 
(compute-beg~bi tpos d) 

(assign fcbd-d-bea-addr (+ bbd-base-pointer b-tetnp)) 
(assign bbd-d-helqht bbd--3ight) 

;; Now copy results down over arguments and array-setup-2d work area 
(assign b-temp fratne-pointer) 

(assign frame-pointer (+ stack-pointer (b-constant 4)}) 
(assian b-temp-2 (+ stack-pointer (b-constant 15.))) 
(parai lei 

(assign stack-pointer (- stack-pointer (b-constant 3))) 

(cal I bl t-stack)) 
(parai lei 

(assign frame-pointer b-temp) 

(assign top-of-stack top-of-ttack-a) 

(next- instruct ion) ) ) 



;;tske an array-register control word in b-temp, return 
;;dispatch type in b-temp. 
(defucode bbd-bi ts-oer-el t 

(d i spatch-af ter- th i s (array-reg i ster-di spatch- field b- 
(nop) 
( (Xarrau-regi ster-di spatch-1-bit) 

(parallel (assign b-temp (set-type (b-constant 0) 
( (Xarr au-reg i s ter-d i spatch-2-b i t ) 

(parallel (assign b-temp (set-type (b-constant 1) 
( (tarrau-regi ster-di spatch-4-bi t) 

(parallel (assign b-temp (set-type (b-constant 2) 
( Ciarrau-regt ster-di sp5tch-8-bit) 

(parallel (assign b-temp (set-type (b-constant 3) 
(darray-regi ster-di spatch-16-bi t) 

(parallel (assign b-temp (set-type (b-constant 4) 
( (larrau-regi ster-di spatch-uord) 

(parallel (assicin b-temp (set-type (b-constant 5) 
(otherwise (si gnat -error unimpiemented-or-i Mega!-ar 



a decoding of i ts 
•temp) 

dtp-fix)) (return))) 

dtp-fix)) (return))) 

dtp-fix)) (return))) 

dtp-fix)) (return))) 

dtp-fix)) (return))) 

dtp-fix)) (return))) 
ray-type)))) 
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;;; -«- FlodeiLisp; Packaqe:nicro; BaseiS; Lowcrca5e;yes -*- 
;;; (c) Copyright 19S2, Symbolics, Inc. 

cMicrocode for the aultipiier 

;Get defmicro and all his hosts 

(declare (cond ((not (status feature Imuccde)} 
(load 'udcls)))) 

The following microcode-controllable signals exist: 
x-twos-ccrrptement 
y-tuos-complement 
x-clk-enabi e 
u-ctk-enable 
Tsp & msp output-enable (select tnpy as Xbus source) 

■sp-ctk and Isp-clk happen every cycle 
feed-through is aluaus off 
right -Shi ft is always on 
round is always off 

nPY-PRCDUCT is a source (on Xbus) 

nPY-X, nPY-X-SIGNED. nPY-Y, PtPY-Y-SIGNED arc destinations 

Note that the X destinations get the low ha If word and the 

Y destinations get the htcih halfuord. 
These destination? are imDiemented by the micros URITE-flPY-X 

and URITE-nPY-Y-FROn-HIGH. which take sn optional SIC^i£D flag. 
Special skips needed: 

ALU-CARRY (out of bit 31, into non-existent bit 32) 

The basic low-level tiultiply subroutine, as a •icro so that the 
locations of the two fixnum arouments and the two fixnum results 
may be varied. No error checking is included. 
The a-source and b-source arouments are the arguments, 

store-low-prcduct and store-hf gh-product are routines to dispose 

of the resul ts. 
finally is stuff to do tn parallel with the last cycle, which 

appears in 4 different copies. 
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Execution time is 9 cycles in nost common case, sometimes 12 cycles. 
Usa^e of temporaries: " (not optimized to minimize number of temporaries!) 

it- temp A swaooed (AH) 

a-terp-2 AL x £H then ALxBH + AHxBL 

b-temp AH X BL 

b-ter.p-2 B suscped (BL) 

b-temp-3 AH x BH 

(detoicro »py-32-32 (a-soupce b-source 

store- lou-product store-high-ppoduct final ly) 
'(sequential 

(assiqn a-temp (Ido ,a-source IB. IG.)) 
(parallel (ur i te-f:;py-x a-temp signed) :AH 

(ur i te-moy-y-from-high , b-source signed) :BH 
(assign b-ten:p-2 (di^^ ♦b-source 16. IS. 0))) 
(parallel (assign b-terrrp-S mp.y-product) ;AHxBH 

(wr i te-mpy-y-from-high b-teff!p-2)) ;EL 
(parallel (assign b-teinp mpy-product) ;AHxBL 

(if (minus-f fxnum irtpy-product) 

(assign b-temp-3 (- b-tcmp-3 (a-constant 1_1S.))) 
(drop-thrcughi ) ) 
(para I lei (uri te-mpy-x ,a-source) ;AL 

(wr i te-mpy-y-from-high »b-sourcB signed)) ;BH 
(parallel (assign a-tenip-2 mpy-product) :ALxSH 

(wr i te-mpy-y-froffl-high b-temp-2) ;EL 

(if (minus-f ixnum mpy-product) 

(asEign b-temp-3 (- b-temp-3 (a-constant 1_16.))) 
(drop- through)) ) 
(parallel (assiqn a-temp-2 (+ b-temp a-temp-2)) 
(i f alu-carry 

(assign b-terrp-3 (+ b-tcmp-3 (a-constant 1_1B,))) 
(drop-throucih) ) ) 
(parallel 

(.store-tow-product ;Low Product 

(set-tupe (+ mpy-product (dpb a-tcmp-2 16. 16. 8)) dtp-fix)) 
(if elu-carry 
(paral leT 

(, store-high-product 

(set-type (+ b-temp-3 (Idb a-temp-2 16, 16.) 1) dtp-fix)) 
, final ly) 
(paral lei 

(, store-high-product 

(tcit-type (-f b-teitip-3 (Idb a-temp-2 16. 15.)) dtp-fix)) 
,final ly))))) 

;Hu! t ipl Icat ion of a 32-bit number bu a 16-btt number. (4 cycles) 
(osfnicrc inpy-32-lS (22-bi t-number Ib-bi t-number 

store- tow-prcduct store-high-product finally) 
* (sequent i a i 

tparaiie! (tjr ! te-mpy-x . l£-b i t-nun:ber signed) ;B 

(wr i te-«py-y-from-high ,22-bi t-nuicber sioned) ;AH 
(assign b-tcrap (dpb ,32-bi t-number IS. 16. 0))) 
(paral lei 

(assign b-temp mpy-product) jAH x B 

iur i te-mpy-y- f ro»-h I gh o- temp) ; AL 

(if (piu£-or-zero-f ixnum mpy-product) 
(paral lei 

(, store- I ow-product 

(set-type (+ mpy-product (dpb b-terap 16. IG. C) ) dtp-fix)) 
(if alu-carry 
(paral lei 

( , s t or e-h i ah-produc t 

(set-type (1+ (Idb b-temp IS. 15.)) dtp-fix)) 
, final ly) 
(paral lei 

(» store-high-product 

(set-type (Idb b-temp 16. 16.) dtp-fix)) 
.finally))) 
(paral tel 

(.store- low-product 

(set-type (+ mpy-product (dpb b-temp 16. 16. 0)) dtp-fix)) 
{ I f aiu-carry 
(paral iel 

(, store-high-product 

(set-type (+ (a-constant 177777 15.) 
(Jdt> b-temp 15. 16.) 
1) 
dtp-f ix)) 
, final ly) 
(paral Iel 

(♦store-high-product 

(set-type (+ (a-constant 177777 16.) 
(Idb b-temp IB. 167)) 
dtp-fix)) 
,f inal Ju))))))> 
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;;; Arithaetic instructions that use multiplication 

(defwicpo set-a-temp (x) 
•(assign a-temp ,x}) 

(deffflicro set-next-on-stack (x) 
•(assign next-on-stack. ,x)) 

; Basic f i xnum multiply subroutine. No error checking. 
; Takes two fixnums on the stack and returns their double-precision 
;prociuct as two fixnums on the stack (lou-order recult is pushed first). 
(defucode 32-bi t-rjui t iply 

(mpy-32-32 next -on- stack top-of -stack 
set-next-on-stacH. neutop 
(return) ) ) 

;Instruction vRrsion of the above, 
(definst Xmul t iply-double (no-operand needs-stack) 
(para! lei 

(check-f ixnum-2args next-on-stack top-of-otack 

(otherwise (s igna i -error wrong- type-argument any (; f ixnun) ) ) ) 
(jump 32-bi t-mul t ipiy) ) ) 

; Generic number tnu! t ip ! teat i on. 
(definst mu I t ip !y-stack (no-operand needs-stack) 
(para I lei 
;; This cant be check-binary-arithmetic-operands-fast because that needs 
;; the spec field 

(check-f ixnum-2args next-on-stack top-of-stack 
(otherwise (sequential 

(trap-no-save) 

(check-b i nary-ar i thine t i c-operands-f ast no-operand Xar i th-op-mu 1 1 1 p I y 

Kultiply-stack f«uin)) 
(Kpy-32-32 next-on-stack top-of-stack 
pop2push set-a-temp nil)) 
;Ncw c'-^eck for overflow. Having trashed our args ue are unpclsrable, 
;but we can turn into a ca I I -quick-external instruction. 
;Fortunately the multiplier hardware does SETZ x SET2 correctly. 
; Over flow occurs if any bits in high word not equal to sign of low word 
(paral lei 

(trap-if (not (alf-ones (- a-temp (complemented-sign-bi t top-of-stack)))) 

mut t ip ly-over f low) 
(next- instruct i on) ) ) 

; Generic number multiplication with an immediate argument 
(definst mul t iplu-immed s i gned- i mmed i ate-operand 

(parallel ^ ;nust check both args for fixnum to Bake magic-number win 

(check-b i nary-ar i thmeti c-operands-f ast aigned-immedi ate-operand Xar i th-op-mul tiply 

wuTt iply-stack fmul) 
(moy-32-lG tcp-of-stack-a macro-signed-immediate newtop set-a-temp nil)) 
; Over flow checking 
(paral le! 

(trap-if (not (ail -ones (- a-temp (complemented-sign-bi t top-of-stack)))) 

mul t ipty-ovcrf low) 
(next- instruct ion) ) ) 

;;; Here a-temp is the top word of the overflowed result 

;;; Uhat we want to do here is convert the B2 bit result to be distributed 31 bits per 

;;; word. Note tnat the only special case is eetz « setz which will give setz in the top 

;;; word and in the bottom, 

•;; *** If it is possible do selective deposit, it would be possible to bum a cycle *«:« 

;;; **« Think about this when you have tims to breath »=•:* 

(defucode ku t t iply-over f low 

(parallel (trap-no-save) 

(assign b-temp (idb top-of-stack 1 31.))) 

;; Clear stgn bit of the bottom word 

(newtop iset-tyoe (Idb top-of-stack 31. B) dtp-fix)) 

;; Put sign oit of bottom into sign bit of top 31 bits 

(assicin a-temp (dpb b-tcr^p 1 31. a-temp)) 

;: Now rotate it into the bottom bit 

(pushval (set-type (rotate a-temp 1) dtp-fix)) 

(take-post- trap mul t ipl icat ive-f ixnum-overf low preserve-stack) ) 

F;>lmach>ucode>map. 1 isp.29 

;;• -»- node: Lisp; Packaae:nicro; Base: 8; Lowercase; yes -»- 
;;; tc) Copyright 13o2, Symbolics, Inc. 

;;; Hicrocode for Hap Cache and Page Tags 



;Get defmicro and at I his hosts 

(dec I ore (cond ((not (status feature Imucode)) 
(load *udc!s)))) 
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;Declared in SYSOFl: ,,. . • ^ ,^ . ^ 

; XUIRED-VIRTUAL-ADDRFSS-HIGH ;Htghest address m uired cold load. 

; XU'F.ED-PHYSICAL-ADDRESS-LC'J ;First physmem it is stored into. 

J ^4lfiED-PHYSICAL-ADDH£5S-HIGH jLast physmem it is stored into. inot used] 

;Do not use any b-ternps in this fi^e, as it is best to be able to ignore map 

;misses when uritinq the rest of the microcode. 

;b-map-vma siust be m the vpp^r IS B-merjory locations to save cycles. 

(reservB-scpatchpsd-memory 2A51 2A52 375 37B) 

(defareg a-irap-addr) ;Physical address to B3p (low 8 bits zero) 
(defbreg b-tiiap-vma) jCopy of VMA or temporary 

(def ine-sysconstant Ipage-pht-miss) 
(def ine-sy scons tan t Xpage-wri te- fault) 

;! Don't forget!!! The map write data come froflr ABUS! Not OBUS! 
(defmicro wr i te-both-aaps (a-source) 
'(parallel . (get-to-abus a-sourcel 

(wr i te-!bus-dev 37 7 nil) 

(microinstruction speed slow-first-half))) 

(defmicro wr i te-Iru-map (a-source) 
' iparal iel , (get-to-abus a-source) 

(wri te-lDu3-dev 37 4 nil) 

(nicroinstruct ion speed slow-first-half))) 

(defmicro write-map-a (a-source) 
'(parallel , (get-to-abus a-sout-ce) 

(wr i te-tbus-dev 37 5 nit) 
(microinstruction speed slou-f irst-hal f ) ) ) 

(defmicro write-msp-b (a-source) 
•(parallel , (get-to-abus a-source) 

(wr i te-lbus-dev 37 6 ni i ) 
(microinstruction speed slow-first-half))) 

jConditional test valid while writing map 
(def atom i cro map- I oad-successfu I 

(microcondi t ion mc-cond true (microinstruction))) 

; Reading pane tags 
(defmicro page-tacj-bi t (n) 

(make-microcondl t ion 'not-lbus-dev-cond 'false 

'(wri te-lbus-dev 3G , (dpb n 8332 3) ml))) 

;0 if miss, non-zero if hit or vma-phys-addr. Bits <33:32> of «ap read data. 

(defatomicro map-select-code 

Iparaile! (microinstruction abus map speed very-slow) 
(Idb ybus-crocks-1 2 12.))) 

;Urite into the gc-map 
Idefmicro wr i te-gc-rr.sp (adr val) 
(paralyze (get-to-aous adr) 

(oet-to-bbu9 va)) 

• Km i cro instruct ion spec toad-special -maps magic 1))) 

;Cle?r the map cache and the PHTC 

;VnA used as a loop coun ter, called tnit tatty with zero in VMA 

(defucode clear-map-cache 

;; Urite both maps with -1 (no-match tag) 

(wr i te-both-maps ta-constant -1)) 

; ; Tiung unt i 1 no good 

(assign vma (+ vmc3 (b-constant 1_8))) 

(if (lesser-pointer vma (b-constant 1_29.)) 
(c!o:o c I car-trap-cache) 
(drop-throunh)) 

;; riaKe sure FHTC address and size, and ASN, are correct 

(wr i te-lbur-dev 37 1 Xrurrent-phtc) 

;; Get lower and upper bounds of Pf-iTC 

(assign a-temp (iogand *current-phtc (b-constant -1_16.))) 

(paraltcl (assign b-temp itiDt^ (b-conctcnt -1) 12. Xcurrent-phtc) ) 
(jump clear -phtc)) ) 

(defucode clear-phtc 
(paral lei 

tstar t-memory write physical a-tepp) 

(assign msmoru-data (set-type (b-constant -1) dtp-fix))) 
(assign'a-temp il+ a-temp)) 
(if (Tecser rr-enua! -pointer a-temp b-temp) 
(gcto clear-phtc) 
(return))) 

;Unnap page whose address is in VHA, from both the map cache and the PHTC 
(defucode clear-page-frotn-map-cache 

;; Clobber both c:aps» not bothering to check whether they really map that address 

:; Could read the map and dispatch on bits <33:32> 

(wri te-both-maps (a-constant -D) 

(start-memory read address-phtc) 
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(assign b-temp (idb vma 8 29.)) ;Extract tag field of VHA 

(if (equa!-f ixnuin b-temp (Idb Biemory-data S 24.)) jCompare against PHTC entry 
(paral lei 

(start-memory write addre59-phtc) 

(assign memory-data (set-type la-constant -1) dtp-fix)) 
(return) ) 
(return) ) ) 

:Ur!nap page whose address is in b-temp, from both the map cache and the PHTC 
(dsfucode c I ear -b- temp-page- from-map-cache 
(parallel (assign vma b-temp) 

{ jump ci ear-page- from-map-cache) ) ) 

; Change map cache and PHTC to map page in VTIA into corresponding stack buffer page 
(defuccde mcp-poge-to-stack-buf fer 

(assign a-terrp (logand vma (b-constant 3_8))) ;Stack buffer page 
(a=sign a-temp (logior a-temp (b-constant 1777G3 8))) ;Phu5ical address 
(assion b-temp (iogand (rotate vma 4) (b-constant 377 24.])) ;VnA tag 
(paraliet 

(start-memory write address-phtc) ;Urite PHTC utth value to go in nap 

tacsign memory-data (set-type (logior a-temp b-temp) dtp-fix))) 
(di spatch-af ter-this map-sel ect-codc- jSee if nap needs to be written 

(assign a-temp (logior a-temp b-temp)) 
((8) (parallel (ur i te-Tru-map a-temp) ;riap cache laiss 

(return) ) ) 
((1) (parallel (wri te-map-a a-temp) ;Replace nap A 

(return))) 
((2) (parallel (ur i te-map-b a-temp) ; Rep I ace nap B 

(return))) 
((3) (return)))) ;Should not get here— ignore 

;Hap-miss traps here in normal case 
(defucode-at-loc map-miss 10091 
;; Copy VMA to B side while waiting for PHTC entry to come from »emory 
(parallel 
(trap-save) 

(assign D-map-vma vma) 
(declare-memory-t ining active-cycle)) 
;; Refili map from PHTC entry and see whether VHA tag in PHTC entry matches 
(paral let 

(trap-restore-1) 
(wr i te-tru-map memory-data) 
(if sjap-load-successrul 
(paral lei 

(trap-res tor e-2) jexi ts 

(assign Hcount-map-re loads (1+ Xcount-ruap-reloads) ) ) 
(goto phtc-mt ssi ) ) ) 

;Come here if paae not found in PHTC, with a trap-restore-1 just done 
(defuccde phtc-mTss 

;; Check for page temporarily mapped into A-memory for stack buffer 

;; Currently we know that there is only one aiappable stack buffer^ the main 

:; stack buffer at 6«A. The auxiliary one is not mappable. 

{paraf lei 

(trap-save) ; undoes trap-restore-1 

(if (cjreater-or-equa I -pointer b-map-vma ^stack-buffer- low) 

Itf ( iesser-or-equal-pointer b-map-vma Xstack-buf fer-1 imi t) 
(sequential 

(assign a-map-addr (logand b-map-vma (a-constant 3 8))) jUhtch e.b. page 
(parallel (assign a-map-oddr (logior a-map-addr (b-constant 1777B8 8))) 
(jump map-miss-sat isf ted)) ) 
(drop-throughi ) 
(drop-through) ) ) 
;; Check for permanent iy-wi red portion of virtual memory 
(if (lesser-pointer b-map-vma %wired-virtua I -address-high) 
(sequent i at 

(ass 1 en a-map-addr (+ b-map-vma ^Cwired-physi ca I -address- low) ) 
(parallel (assign a-map-addr (logand a-map-addr (b-conatant 177777 8))) 
(lump mcp-mi ss-sat isf ied) ) ) " 

(drop-throughf ) 
;; Escape to macrocode man miss handler. Don't leave garbage in the rap. 
(wr i te-lru-rr.3p ta-constant -1)) 
(parallel (assign a-temp tnaqe-pht-mi ss) 
(jump page-faul t) ) ) 

xHere with a-map-addr containing the physical page to map to, in bits 23-8 

(defuccde map-miss-satisfied 

;; Get VTiA tag field properly aligned, and no wr i te-protect 
(assign b-map-vma (logand (rotate vma 4) (b-constant 377_24.))) 
(assign a-map-addr (logior a-map-addr b-map-vma)) " 
(trcp-restore 

;; riaintain metering counter 

(assign !icount-map-re loads (1+ tcount-map-reioads) ) 

;; Refill I east-recent lu-used map location addressed by VnA 

(wr i te-lru-map a-map-addr))) 
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:nap miss uhile in block, read, YHA incpenientecl one or two extra times, 
:no PHIZ prcDe in prcciress. 

;For thc^e I am just going to pclsr and try again (could check PHTC first) 
(defucodc-at-ioc map-oi ss-blocki IBCll 
(paral iel 
(trap-save) 

(assign vna (- vma (b-constant 1)))) 

(parallel (assign a-temp Xpaae-pht-niss) 

( jump"page-f aul t) ) J 

(defucode-at-!oc map-mi ss-b I ocK2 12321 
(para I lei 
(trap-save) 

(assign vma (- vma (b-constant 2)))) 

(parallel (assign a-temp Xoaqe-pht-miss) 

(junp page-fault))) 

;Here if map miss while in block write, or write protect violation 
;No proper PHTC probe in progress 
(defucode-at- loc map-wr i te-m' es 18031 

;; Read the map to determine which it is 
(parallel 
(trap-save) 

(if (zero-fixnum map-seiect-codc) 
(paral iel 

(trap-restore-1) 
(assign b-frap-vffa vma) 
I jump phtc-tni ss) ) 
(parallel 

(assign a-temo tpaoe-wr i tc-f3ul t) 
( jump page-faui t) ) ) ) ) 

;HardHare subprini fives 

;Argu*ments are vma and word to be written 

;Ue Bust clobber any previous mapping for that virtual pago 
jHacrocode takes care of any necessary clobbering of FHTu 
;The 8 esse here is a itttle bit of overkilr; we could simply never touch 
: tne Rap when there was a miss, and let a refill from Pn'TC take care of tt» 
(definst Imap-cache-wr i te (no-operand smashes-otack) 
(paral iel 

(check-arg-tupe next-on-stack dtp-fix) 
(ass ion vma riext-on-stack) 
(decrement-stack-pointer) ) 
(paral lei 

(dispatch-aftcr-this nap-select-cods . ^ 1^^ _.. ^- \ 

(check-arg-tuoe 1 (amen (stack-pointer D) dtp-fix) 
((0) (if (all-ones (amem (stack-pointer 1) ) ) ;n5p cache mi ss. Clearing? 

(parai Iel (decrement-stack-pointer) ;Ciearing— leave alone 

(next- instruct ion) ) 
(parallel (wr i te-lru-map (amem (stack-pointer 1))) ;Uriting — put into LRU map 
(deer ement-stack-QO inter) 
(next- instruct ion) ) ) ) 
((1) (parallel (write-map-a (anen (stack-pointer 1))) ;Originai TOS to nap A 
(decrement-stack-pointer) 

(next-instruction) ) ) 

((2) (parallel (write-map-b (amen (stack-pointer 1))) ;OriginaI TOS to «ap B 
(decrertent-s tack-pointer) 
(next-instruct ion) ) ) 
((3) (parallel (decrcnent-stack-pointer) ;Should not get here— ignore 

(next- instruction? 1) ))) 

:Use the PHTC hashbox to reB6 an entry. Arg is virtual address, 
(definst ^Cphtc-resd no-operand 

(parallel . , 

(check-arg-tupe top-of-stack-a dtp-fix) 

(assiqn vma top-of-stack-a)) 
(start-memory read acdress-phtc) 
(nop) 
(paral Iel 

(transport data) ;Crash here if no data typa tag 

(newtcp memoru-data) 

(next- instruct ion) ) ) 

;Use the PHTC hashbox to writs an entry. Args are virtual address and entry. 
(definst Iphtc-write (no-operand smashes-stack) 
(paral Iel 

(check-arg-type next-on-stack dtp-fix) 

(assign vma next-on-stack) 

(dscrement-stack-pointer) ) 
(paral Iel 

(check-arg-tupe 1 (amem (stack-pointer 1)) dtp-fix) 

{start-mer::-y write addrecs-phtc) 

(assign r.e-iOry-data (amem (stack-pointer 1))) 

(decrement -stack -pointer) 

(next- instruct ion J ) ) 

;Urite into the PHTC address, size, ASN register 
(definst titrhtc-setup (no-operand needs-stack smashes-stack) 
(paral lei 



;nove address to fastsr memory 
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(check- f ixnum-larn-b top-of -stack) 
iur i te-lbus-dev 3/ 1 top-of-stack) 
(assign Icurrent-phtc top-of-stack) 
{flscrement -stack-pointer) 
(nex t- ins true t ion) ) ) 

;5et up address for paoe tag 

:You nad better have disabled tasking in the previous cycle 

(defipicro address-pacie-tag {phys-ad^r) 

' istart-memcry reaa physicat ,phys-addr inhibi t-page-tags) ) 

;Urtte into the page reference tag frorr. t or nil 
(definst Xreference-tag-wr I te (no-operand smashes-stack) 

(ass ion a-terr.p next-on-stack) ;riove address to faster Demcry 

(paraT lei 

(decrcment-stacK-po inter) 
(di sab le-tasKing) 

(if (data-tyoe? top-of-stack-a dtp-nil) 
(sequent ia I 

(parallel (check-arg-type 9 a-terrp dtp-fix) 

(address-page-taq a-tenp)) 
(parallel (wr i te-tbus-dev So 21 nil) 
(decrement-stack-pointer) 
(next- instruct ion) ) ) 
(sequential 

(parallfc! (check-arg-type 8 a-tenp dtp-fix) 

(address-pcce-tcq a-tcT:p)) 
(parallel (ur i te- Ibus-dev 2o 31 nil) 
tdecrement -stack -pointer) 
(next- instruct ion) )))) ) 

;^e3:; reference tag 33 t or ni I 
(ceiirst "«:e t£?rence-t jg-re3d no-operand 
(parai iei 

(disable- tacking) 
(assign a-tcrap top-of-stack-a) ) 
(parallel 

(check-arg-type 9 a-temp dtp-fix) 
(address-pagi-taa a-temp)) 
(if (page-tag-bf t 1) 
(goto truel) 
(goto faisel)}) 

;Urite into the GC tag from t or ni 1 

(definst tigc-tag-ur i te (no-operand smashes-stack) 

(assign a-temp next-on-stack) tMove address to faster memory 

(parallel 

(disab.le- tasking) 
(decretnent-stack-pointf^r) 
(if (data-type? top-of-stack-a dtp-nil) 
(sequent i a I 

(parallel (check-arg-type 9 a-temp dtp-fix) 

(address-page-tag a-temp)) 
(parallel (wr i te- Ibus-dev 35 CI nil) 
(decrement -stack-pointer) 
(next- instruct ion) )) 
(sequential 

(parallel (check-arg-type 9 a-temp dtp-fix) 

(address-paoe-tag a-temp)) 
(parallel <wr t te-l&us-dev ^B 11 nil) 
(deer eisent-stack-co inter) 
(next- instruct ion) ) )) ) ) 

;Read GC tag as t or ni I 
(definst Xqc-tag-read no-operand 
(parat iei 

(disable-tasking) 
(assign a-temp tcp-of-stack-a) ) 
(parallel 

(check-arg-type 9 a-temp dtp-fix) 
(address-page-tao a-temp)) 
(if (page-tag-bi t 9) 
(goto trusl) 
(goto faisel))) 

;Scan the reference tags» returning NIL or the physical address of the first page 
;uhoce tag is not set. As we pass over each tag uhich is set, clear it. 
;No time available for type checking the second argument 
(definst %£can-ref erence-tags (no-operand needs-stack) 
iparal te I 

(check-arg-type 9 next-on-stack dtp-fix) 

(if (grcater-or-equal -f ixnum-unsi cned next-on-stack top-of-stack) 
(parallel (pop2push quote-nil]* 

(next- instruct ion) ) 
(drop-through) ) ) 
(paral le! 

(assign a-temp next-on-stack) ;t1ove address to faster tiemory 

(disable-tasking) ) 
(address-page-tag a-temp) 
(paral lel 



;riove address to faster eemory 
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iif (not (page-tsg-bi t D) 

(paratteT (pcp2push next-on-stack) 

(next-instpuct ion) ) 
(drop-through) ) 
(disabie-tasking)) 
taddress-psae-tag a-temp) . .%. 

(parallel (assign next-on-stack (+ next-on-stack (b-constant »p3ge-si2e*} ) ) 
(wr i te-tbus-dev 35 21 nil) 
(jun:p tscan-rcterence-tags) ) ) 

;£can the CC tags, returning NIL or the physical address of the first page uhose tag is set. 
;Tnis is buirned for speed (2 cycles per page), 
(definst Xscan-gc-tags (no-cperand needs-stack) 
(para I lei 

(check-fixnum-2arns next-on-stack top-of-stack) 

(assign a-temp ncit-on-stack) ) tMove address to faster memopy 

(parallel ^ . .^^ 

(assign b-tcwD (- top-of-stack-a (b-constant *paQc-st2e*) )) 

(disable- tasking) 

(jump scan-gc-tsgs-ioop) ) ) 

(defucode scan-gc- tags- loop 

;; First cycle emits physical address, checks for done 
(para I lei 

(adoress-page-tag a-terrp) 

(if (greater-or-equal-f ixnum-unsigned a-temp b-temp) 

;; Doing laot location (do it differentiy to avoid reading random address) 
(if (page-tag-bit C) 

(parallel (pcp2push (set-type a-tenp dtp-fix)) 

(next-instruct ion) ) 
(parallel (pori2push quote-nil) 
(next- instruct ion) ) ) 
(drcp-thrcur?h) ) ) 
;; Second cycle tests the tsg bit, increments address, di rubles tasking after next 
(pcrai lei 

(assign a-temp (+ a-temp (b-constant «page-size») ) ) 
(di sable-tasking) 
( i f (page-tag-bi t 0) 

(parallel (pop2push (set-type (- a-temp (b-constant jrpac^-s'zc*) ) dtp-fix)) 
(next- instruct ion) ) 

(goto scan-gc-tags-loop) ) ) ) 

;Urite into the gc map, Args are virtiiat address and contents (including odd parity). 
(definst Xac-«ap-ur i te (no-operand needs-stack smashes-stack) 
(parai iel 

(check-f ixnum-2apgs next-on-stack top-of-stack) 
(decremcnt-s tack-pointer) ) 
(paral Iel 

(ur i te-qc-map top-of-stack-a top-of-stack) 
(decrement -stack-pointer) 
(next- instruct ton) ) ) 

F:>lmach>ucode>IFU.LISP.56 

;;; -»- ModeiLisp; Packaocitlicro; BasetS; Lowerca8e:ye3 -*- 
;;: (c) Copyright 13&2, Symbolics, Inc. 

; riicrocode for IFU stmutation 

:Get defMicro and all his hosts 

(declare (cond ((not (status feature Imucode)) 
(load *udcls)))) 

(resei-ve-scrctchpad-Biemory 2448 2444) 

(defareg a- instruct ion) ! Current instruction 

(defareg a-break-pc B) ;Stop before executing instruction here 

(defucode ma in- loop 

(parallel (assign vma pc) ;Fetch instruction (pair) 

(assign b-temp pc) 

(check-data- tu£e pc dtp-evcn-pc dtp-odd-pc) 

;; Increment Pu» start (rer?:cry, take appropriate instruction halfwcrd, 
:; and halt if macrocode breakpoint reached 
(if (data-type? pc dtp-even-pc) 
(sequent i a 1 (para I t e I 

(start-memory read) 
(assign pc (set-type pc dtp-odd-pc))) 
(if (equai-tuped-po^nter b-temp a-break-pc) 
(parallel 

(assign a-tnstruct ion (Idb Bemory-data IS. 0)) 
(halt breakpoint)) 
(assign a-instruction (Idb nemory-data 16. 0)))) 
(sequential (paral lei 

(start-memory read) 

(assign pc (set-type (1+ pc) dtp-even-pc))) 
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(if (equai-tuped-po inter b-teop a-break-pc) 
(papal iel 

(assign a-instruction (tdb ucuory-data 16- IBJ) 
(hal t breaKpoint)) 
(assign a-instruction (Idb iiemopy-data 16. 16.)))))) 
(assign b-temp (logand (rotate a-instruction 25.) ;(idb 8 8) then shift left 2 

(b-constant 377_2))) 
(parai iel . 

( i ong-di spatch b-temp) ;Can*t overlap uith byte operation above 

(call-and-return-to eain-loop-l Kain-ioop))) 

(defucode main-loop-1 
(parai Iel 

(assign inst (Idb a-instruction 8 0)) 
(take-dispatch))) 

(def ucode-at-loc no-operand-subdispatch 376_2 

(assign b-temp (dpb a-instruction 9 2 (b-constant 10C3_2) ) ) 
(long-dispatch b-tenp) 
(take-dispatch) ) 



F:>lroach>ucode>funcall3.11sp.61 

... .». node:Lisp; PackaacrMicro; Ba£c:&; LowfiPca8e:ij82 -a-- 
;;; (c) Copyright 1922, Symbolics. Inc. 

; flicrocode for function call/return (part 4) 

; This file contains function return u housekeeping instructions 

; use fast-bl t-stack rather than bit-stack, but make it take 

; — its argument in xbas so we don't have to save and restore f? 

;Get definicro £nd all his hosts 

(declare (cond ((not (status feature Imucode)) 
(lood 'udcis)}}) 

;;; Function Return 

;7omporary registers local to these routines 
(reserve-scratchpad-memory 2423 2424) 

(defareg a-tGmp-prev-frar:e) 
(defareg a-tetrp-mi sc-data) 

;Typicsl of a class of single value returning instructions which try 
; to use a quick path through the code if no special conditions occur. 

ICarc is needed in dealing with the PC. If we page fault on an instruction 
' ; fetch, the current frame had better be one that wa are supposed to be 
;returnina from, the top of the stack had better be the value being returned, 
;and the PC had better point at a RETUnN-STACK instruction. 
;Uith the real IrU, the EPC remains pointing at the original return-stack. 
;0n the PROTO machine and the simulator, no page faults can occur, 
•Uith the Tr'iC, writing the PC cannot be undone, so we avoid page 
; faults by not pre-fetching the instructions being returned to, 
; losing soroe time. 
;0n the Tt^iCS, 

(def inst return-stack (no-operand needs-stack) 
(keep-function-history return) 

(parallel (check-arg-type return-pc frame-return-pc dtp-even-pc dtp-odd-pc) 
(assign pc f rarre-return-pc) ) 

(sequential ; make this parallel when you are trying to make the machine fast 

; I would suggest putting lognand inio the non-wierd alu functions 

(trap-i f (not -zero- f ixnum frame-c i eanup-bi ts) 

tflust escape to the slower, more general return microcode. 
(parallel (trap-no-save) 

(assign a-tenp (set-type (b-constant 1) dtp-fix)) 
(assign b-terr.p obus) 
(jump genera t -return) ) ) 
(mach i ne-versi on-case 

((ifu tmc5) (start-memory read block instruction-fetch)) 
(otherwi se nil))) 
(parallel (assign stack-pointe*" frar.e-previous-top) 

(di spatch-af ter-thi s (cdr-code frame-previous- top) 

(assign frame-pointer frame-previous-frame) 
((0) ;Igncre 
(parallel (assign top-of-stack top-of-stack-a) 
(next- instruct ion) ) ) 
(d) :Stack 
(paral Iel (pushva! tcp-of-stack) 
(next- instruct ion) ) ) 
(t2) ;Return 
(parallel (puchval top-of-stack) 

(clear-stack-adjustment) 
(jump return-stack))) 
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((3) :nu!tiple 

(puchvai top-of-stacK) 

(p^irailel (pu£hval (set-type (b-constant 1) dtp-fix)) 
inext- instruct ion) )))) ) 

;The rore general, mui t ip! e-vai ue-returni ng instruction 
(definst return-n unsigned-irnnediate-operand 
; — insert code here to look at all the values and do unsofe-ptrchocks 
(parailet (assign a-terrp (set-type mocro-unsigned-imnediato dtp-fix))' 
(assign b-ten-.p obus) 
{jump general-return))) 

;TKe even more rsneral one, returning a variable nurrber of values 

;The count is on tne stock, i.e. it (s a multiple group 

(definst return-irul t ip le no-operand 
; — insert code here to look at all the values and do unsafe-ptr checks 
(parallel (chcck-arg-tupe top-of-5t;>ck top-of-stack-a dtp-fix) 

(aSbiO'** a-tefT;p tOp-Of-StiCK-2) 

(assign b-temp obus) 
(dccrcnsnt-s tack-pointer) 
(jump general-return))) 

;Values to be returned are on the stack 

; Values on the stack have already been filtered for. unsafe pointers 
;The top-of-stcck rejister need not be valid 
ca-te-^p c-.d b-terp have the number of values 

;Tne PC is irrelevant since if we trap, we will change the PC to point 
;to a pcturn-mut t iple instruction, and push the number of values onto the stack, 
;This is necessary since we can get here from a variety of different, 
s Incompat ibie return instructions, and we don't know hew to restore their 
; arguments so that they can be used to retry the return operation. 
;We cannot do instruction prefetching on the code being returned to, 
; because the page fault would happen with the pc inconsistent with fp/sp. 
(defuccde genera I -return 
;; The general idea is to bit the values down fro* the top of the returning 
;; frame to the top of the caller frame, then check whether the caller 
;; frame needs to brought into the stack buffer. But we start by dispatching 
;; on the value disposition which affects whetner or not we Lit all the 
;; values down as well as what to do about the PC. 
(keep-funct ion-history return) 
(di spatch-af ter-th t s Tcdr-code frame-prevroas-top) 

;; Xct-next: Check for exceptions other than stack buffer underflow 
(trap-if (bit-test frame-miscTdata 

(b-constant ( I ogxor (byte-mask f rame-buf fer -under f I ou-b i t ) 
(byte-nask frame-cleanup-bi ts)) ) ) 

?encra I -return-c I eanup) 
gnore 
(parallel (check-arg-type return-pc frame-return-pc dtp-even-pc dtp-odd-pc) 

(assign pc frame-return-pc)) 
(assign stack-pointer f rame-previous-tcp) 
(assign top-of-stack top-of-stack-a) 
iif (not (bit frame-buffer-underflow-bit)) 

(parallel (assign frame-pointer frasie-previous-frame) 

(next- instruct ion) ) 
(sequential (assign frame-pointer frame-previous-frame) 

(take-post-trap reload-stack-buf fer preserve-stack)))) 
((1) ;Stack 
(parallel (check-arg-type return-pc frame-return-pc dtp-even-pc dtp-odd-pc) 

(assign pc frame-return-pc)) 
(if (:ero-fixnum a-temp) 

;; Returning no values. Return nit (rather than error!) 
(assign too-of-stack quote-nil) 
;; Return first value 
(sequential 

(assign stack-pointer (- stack-pointer b-temo)) 
(assign top-of-stack (amem (stack-pointer 1))))) 
(assign stack-pointer frame-previous-top) 
(if (not (bit frame-buffer-underflow-bit)) 

(sequential (assipn frame-pointer f rame-previcus-frame) 
(parallel (pushval top-of-stack) 
(next- instruct ion) ) ) 
(sequential (assign frame-pointer frame-prcvious-frame) 
(pushval top-of-stack) 

(take-post-trap reload-stack-buf fer preserve-stack)))) 
((2) ;Return 
(parallel (assign a-temp-mi sc-data frame-«isc-data) 

(ca I ! b I t-va 1 ues-down) ) 
(assign frame-pointer a-temp-prev-frame) 
(if (not (bit-test a-temp-m i sc-data 

(b-constant (byte-mask frame-buffer-underflow-bit)))) 
;Now return from caller's frame to his caller 
(coto general-return) 

;neload stack buffer, then popj to RETURN-rHXTIPLE instruction 
(sequent iai 

(pushval (set-type a-temp dtp-fix)) jNumber of values returning 

( take- jump-trap-wi th-continuat ion reload-stack-buf fer 

return-au 1 1 i p I e-escape-pc 
preserve-stack)))) 
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{(2) tHuitiple 
(parallel (checR-arg-type return-pc frams-retupn-pc dtp-even-pc dtp-odd-pc) 

(assign pc frane-return-pc) ) 
(parallel (assian a-terp-mi sc-data frane-sii sc-data) 

(cal Tbi t-vaiues-doun) ) 
(assign frane-pointer a-tenp-prev-frane) 
(if (not (bit-test a-tenp-m i 6c-data 

(b-constant (byte-mask frame-buf fer-underf low-bi t) } ) ) 
;;Ncu finish off by storing number of values returned 
(parallel (pushvai (set-type a-temp dtp-fix)) 

(nex t- instruct ion) ) 
;;Reio3d stack buffer, then popj 
(sequent ia : 

Ipushval (set-type a-temp dtp-fix)) jNumber of values returning 
(take-junp-trap-wi th-cont inuat ion reload-stack-buf fer pc presepve-stack)))))) 

;Here tf a frame being deallocated needs some cleanup, typically popping 
:of associated binding and data stack frames, or checking of potentially 
cunsafe pointers. The cleanup may involve calling a macrocode routine 
;and arpanging for it to return to an appropriate PC. 

;lf an error signalled here, the PC mau not be meaningful (due to d-return) 
;Note that tf we go back around to genera I -return a-temp and b-temp must still be valid 
(de f ucode aenera I -return-c leanup 
(paral lei 

(trap-no-save) 
(i f (bi t frarre-catch-bi t) 
(goto catch-cleanup) 
(drop-through) ) ) 

(if (bit frar«e-b ! ndinas-bi t) 
(seauent i o I 

(paral lei 

(pushvai (set-type a-temp dtp-fix)) iNumber of values returning 
(ciear-stack-adjustment} ) ;Leave this in the stack if we trap 

(restapt-pc return-mul tiple-escape-pc) ;PC -> RETUn^v-nULTIFlE instruction in 
(parallel ; case of a page fault 

(accept-restapt-pc) 

(cal 1 frame-cleanup-bind-stack-unuind) ) 
(parallel (assign a-temp top-of-stack) ;Retrieve number of values 
(assign b-temp top-cf-stack) 
(aecrement-stack-po inter} 
(iump genera I -return) ) ) 
(drop- through! ) 

(if (bit frame-bottom-bit) 

(sequential -Return one value frcn stack group 

(if (rero-fixnum a-tcmp) 

;Ret'jrntng no values. Return nil (rather than errop!) 
(pushva! quote-nil) 
rHeturn first value 

(sequential (assign xbas (- stack-pointer b-temp)) 
(pushvai (amem (xbas 1))))) 
(take- jump-trap stack-group-exhausted preserve-stack)) 
(drop-through) ) 

(if (bit frame-trace-b( t) 
(sequential 

(pushvai (set-type a-temp dtp-fix)) 'Hake values a multiple group 

(signai-error-no-restore-stack return-from-traccd-frame) ) 
(drop-tnrough) } 

;Some unknown frame-cleanup bit was set 

(pushvai (set-type a-temp dtp-fix)) tflake values a multiple group 

(signal-error-no-restore-stack garbage-m-frame-cleanup-bi ts) ) 

:Get rid of a catch block in this frame, then try to retupn again 
;Prepepve a-temp and b-temp (for general-return) 
(defucode catch-cleanup 

(assign xbas Xcatch-b 1 ock- ! i st) :Inspect the catch block 

(if (equal -typed-pointer (amem (xbas C) ) ;catch-block-tag 

b-quote-t) ;unwind-protect ( change tag later ) 

(sequent i a I 
(paral lei 

(pushvai (set-type a-temp dtp-fix)) ;Number of values returning 
(c leap-stack-adjustment)) ;Le3ve this in the stack if we tnap 

(pestart-pc peturn-mul tiple-escspe-pc) ;R£TURN-nULTIPLE instruction pair 
(parallel (accept-restar t-pc) 

(assign a-catch-nwords (1-f a-temp)), 

(iump catch-close-l))) ;Run cleanup handler then retry return 
(dpop-thpoughj ) 
;Not an unuind-ppotect. Simply unthre?.d it fpom the list and continue 
(parallel (assign '^catch-biock-l i st (amem (xbas 3))) ;catch-b lock-previous 

(assign b-tsmp-2 obus)) 
(if (data-type? Xcatch-b lock- I ist dtp-nil) 

(parallel (assign frame-catch-bit (b-constant 0)) 

(jump qenenal-petupn) ) 
(if (lessep-pointer b-temp-2 franr.e-po inter) 

(parallel (assign frame-catch-bit (b-constant B) ) 

(jump general-return)) 
(goto catch-cleanup)))) ;more catch blocks in this frame 
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;Sut»routme of genera (-call for case where ail values may be needed 

;Siiipiy sets up the correct arguments for bIt-etacK 

;fieturns with correct value in stack-pointer 

;and a-teKp-prcv-fraitie having what belongs in fi*ame-po inter 

;Here the number of values is in a- temp and b-temp rather than 

;on the top of the stack 

<defucode bl t-va lues-doun 

iasijign a-temp-2 frarr.e-previous-top) 

(assign a-temp-prev-fratne frame-previous-frame) 

{parallel (assign frame-pointer (- Etack-pointer b-teirp)) 
(assign b-temp-2 stack-pointer)) 

(parallel (assign stack-pointer a-tcT.p-2) 
( jump'bl t-stack) J ) 

;Soaie words are to be pushed into the stock, frame-pointer points before 

; the first of them and b-temp-2 points at the last of them. 

; fraae-pointer is smashed. 

;3 cycles per word moved plus 3 cycles of overhead, 

tCould be sped up to 2 cycles per if ue had two counters that addressed Amem. 

(defucode bit-stack 

(assion frame-pointer (1+ frame-pointer)) 

(if (greater-pointer frame-pointer b-temp-2) (return) 

(parallel (pushval-ui th-cdr (amcm (frame-pointer 8))) 
(jump bit-stack)))) 

;Fast version of above, using unrolled loop 

;Some words are to be pushed into the stack, frame-pointer points before 

;the first of them and b-temp-2 points at the last of them. 

; fraae-pointer, a-temp2 are smashed. 

;Ti»e to move N words - 2+N (1<N<9) 

; K«8 «> 2. N-l -> 4. N>S -> ll(N/8}+tiKe(N nod 8) (-3 if N nod 8-8) 

;35 control memory locations. 

(defucode fast-bit-stack 

(parallel ;Neaative number of words to do, ainus one to «ake ALU happy 
(assign a-temp-2 (set-type (- frams-pointer b-temp-2 1) dtp-77) ) 
(i f (equal-pointer frame-pointer b-temp-2) (return) 
(para I tel 

(if (»inus-f ixnum (+ a-tcmp-2 (b-constant 8) 1)) 

(sequential ;I1ore than 8 words, wove 8 and retry 
(paral lel . 

(pushval-wi th-cdr (amem (frame-pointer 1))) 
(cal I fast-bl t-stack-S)) 
(para! lei 

(assign frame-pointer (+ frame-pointer (b-constant 8))) 
(jump fast-bit-stack))) 
(parallel ;tes8 than 8 words, move 1 and dispatch 
(pushval-wi th-cdr (amem (frame-pointer 1))) 
(take-dispatch) ) ) 
(disoatch-af ter-next (Jdb a-temp-2 3 8) 

((d) (return)) ;1 

((5) (parallel (pushvat-wt th-cdr (anem (frame-pointer 2))) ;2 

(return))) 
((4) (pushva I -ui th-cdr (amem (frame-pointer 2))) ;3 

(parallel (pushval-wi th-cdr (amem (frame-pointer 3))) 
(return))) 
((3) (pushval-wi th-cdr (amem (frame-pointer 2))) ;4 

(pushval-wi th-cdr (amem (frame-pointer 3))) 
(parallel (pushval-wi th-cdr (amem (frame-pointer 4)) ) 
(return))) 
((2) (pushval-wi th-cdr (amem (frame-pointer 2))) ;5 

(pushval-wi th-cdr (amem (frame-pointer 3) ) ) 
(pushval-wi th-cdr (amem (frame-pointer 4))) 
(parallel (oushval-wi th-cdr (amem (frame-pointer 5))) 
(return))) 
(d) (pushval-wi th-cdr (amem (frame-pointer 2))) :S 

(pushva I -ui th-cdr (amern (frarae-po inter 5))) 
(pushva I -ui th-cdr (amem (frame-pointer 4U ) 
(pushval-wi th-cdr (amem (frame-po inter 5))) 
(parallel (pushvaZ-wi th-cdr (amem (frame-pointer B) ) ) 
(return) )) 
((8) (pushva 1 -wt th-cdr (amem (frame-pointer 2))) ;7 

(pushva I -w I th-cdr (amem (frame-pointer 3))) 
(pushval-wi th-cdr (amem (frame-pointer 4))) 
(pu£hval-wi th-cdr (amem (frame-pointer 5))) 
(pushva I -wi th-cdr (amcm (frame-pointer 6))) 
(parallel (pushval-wi th-cdr (amem (frame-pointer 7))) 
(return))) 
((7) (goto fast-blt-stack-g))))))) ;8 



(defucode fast-bl t-st-ack-8 

(pushva !-w( th-cdr (amem (f'-ame-po i ntcr 2))) 

ipusnval-wi th-cdr tame:^ (frame-pointer 3))) 

(pushval-wi th-cdr (amen (frame-pointer 4))) 

(pushva I -ui th-cdr (amem (frame-pointer 5))) 

Ipushva I -wi th-cdr (amem (frame-pointer B))) 

iD'j:hval-wi th-cdr (amem (frame-pointer 7))) 
(pcrallet (ou£hva I -ui th-cdr (amem (frame-pointer 8))) 
(return) ) ) 



lass 
(para! lei lass 
(para) iel (ass 

(ass 
(parai let (ass 

(cat 
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(definst popi no-op?rand 

(parallel (check-arg-tuDe top-of-stcck top-of-stack-a dtp-evcn-pc dtp-odd-pc) 
(set-pc top-of-stack-a 

(for-effect (popval))))) 

:Top N stock locations to be preserved, squeeze return PC cut from under there 

; This can be written better when bit-stack is changed to use xcas 

(definst poDj-n unsigned-imfnediate-opcrand 

(asstan xbas (- stack-pointer macro-Linsioned-imrrLcdiate)) 

(parallel (check-^rg-tuce nil (ameni (xbas 0)) dtp-evcn-pc dtp-odd-pc) 

gn a-tcrr.p-Z (amew (xbas 0)))) 

gn a-teirp frame-pointer)) 

gn frame-pointer (- stack-pointer nacro-uns igned-i sirred i ate) ) 
gn b-ter:p-2 stack-pointer)) 
gn stack-cointer (1- frame-pointer)) 
bl t-stackl ) 
(assign frame-poir.ter a-ternp) 
(set-pc a-temp-2)) ;Set PC after all side-effects out of way, in case pg fit 

;nultipie at top of stack to be preserved, squeeze return PC out from under 

. Thrs can be written better when bit-stack is changed to use xbas 

(definst pop j-mul t ip te (no-operand needs-stack) 
(assign xbas (- stack-pointer top-of-stack 1)) 
('parallel (check-arg-tvpe nil (amem (xbas 0)) dtp-even-pc dtp-odd-pc) 

(assign a-te.T.p-2 (atnem (xoas 0)))) 
{parallel (assign a-terp frame-pointer)) 
(parallel (assign frane-po inter (- slack-pointer top-of-stack 1)) 

(assian b-tcmp-2 stack-pointer)) 
(parallel (assign stack-pointer (1- frame-pointer)) 

(cat 1 bit-stack) ) 
(assign frame-pointer a-temp) 
(set-pc a-tefflp-2)) :Set PC after alt aide-effects cut of way, in case pg fit 

: Instruct ions for picking up multipfe values (eft in the stack 

:For now, the only one I will do is the one for a fixed numb.r of 
:values, not the »ul t iple-value-i i«t, Aoptional, and drest ones. 

:The values and the number of them are on the stack, 

;Take specified number of values. Adjust the size of the block of values 
;on the stack, and get rid of the values count. 
(definst take-values unsigned-imnediate-operand 
(parallel 

(check-aro-type top-of-stack top-of-ctack-a dtp-fix) 
(if (equal-f Ixnum top-of-stack-a Kacro-unsigned- immediate) 
;H3ve right number of values, just flush count and exit 
(paral leT (for -effect (popval ) ) 

(next- instruct ioni ) 
(drop- through) ) ) 
(parat let 

(assign b-terrp (- top-of-stack-a uacro-unstgned-imraediate) ) 
<decrcment-stack-po i nter ) 

(if (pius-or-zero-f ixnum obus) ;-or-2ero to make ALU happy 
:Have too many values, flush extraneous ones and the count 
(sequential :Pop extraneous values 

(assign stack-pointer (- stack-pointer b-tenp)) 
(parallel (assign top-of-stack (amem (stack-pointer 8))) 
(next- instruct ion) ) ) 
;Not enough values, push some NILs 
(goto push-missing-values)))) 

;Pu8h (minus b-temp) nils 

jThis takes two cycles per nit, and could be bumned to take 9/8 cycle 

(defucode push-missing-values 

(parallel (assign b-terap (1+ b-temp)) 

(if (plus-or-zero-f ixnum obus) 
(parallel (pushval quote-nit) 
(next- instruct ion) ) 
(parallel (pushval quote-nil) 

(jump push-mi ssing-vatues) ))) ) 

;;; The more general, slouer catling code (r^re than 4 arguments, 
:;; variable number of arguments, restarting from trapped call) 

;This instruction starts up a call in the current fpanc. Normally there 
;ui I I be nothing pusi^ed after the frame header, but there could be ?.n 
;environment or ether extra arguments, 
(definst restart-trapped-ca 1 I no-operand 
(di spatch-af ter-nsxt frDr7!e-araumGnt-format 

( (iframe-argumenxs-normal ) Tgoto genera I -cat I-l) ) 

( (Xframe-arguments-iexpr) (qoto rostar t-lexpr-funca 1 I ) ) 

( (Iframe-arguments-instance) (goto metnod-cal 1-1) ) 

( (Xframe-arguraents-lexpr-tnstance) (goto restart- I expp-nethod-ca ! I ) ) ) 
(paral Iel 

(assign a-nargs frame-number-of-args) 

(assign b-temp frame-number-of-args) 

(take-dispatch) ) ) 
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;Current frame is ail set up and a-narns has the nunber of arguments* 
:Perform the cal I 
(defucode genera I -cat 1-1 

(paraileT (trap-if Inot-data-type? frarre-funct ion dtp-compi Icd-f unction) 
general-cat i-funn-j- function ) 
(funct ion-entry-instruct icn-fetch frame-funct ion) ) 

;Last place to page fault. Point PC after the entry instr, not 
•.setting it until we are guaranteed there will be no pace fault. 
:lf caller gave many args, only slow case of cailee applies 
;Otherwise dispatch to appropriate code for number of aros 



(disoatch-af ter-next Tidb a-naros 3 9) 
((0) (goto cal !-indirect-disp-9)l 
((1) (goto cal l-indtrect-di sp-1) ) 
( (2) (goto cal l-indirect-di Ep-2) ) 
((5) (aoto coi ! -indirect-di sp-3) ) 
((A) (goto cali-indirect-disp-4)) ) 
(para I Ic-T 

(trap-if (areater-f ixnum a-nargs (b-constant 4)) 
(parallel 

(trap-no-save) 

(declare-mer.ory-timing data-cycie) ;compiier check is conservative 
(If (rero-fixnum (entry-instruct ion-di spatch »emory-d3ta) ) 
(sequent iai 

(keep-funct ion-hi story call) 
(next- instruct ion) ) 
(s i gna!-error-no-r ester e-s tack urong-number-of -arguments) ) )) 
(take-dispatch))) 

;Same when entering a icsthod. The first two arguments have already been pushed into 
; the cal lee's frar.e. 
(defucode methcd-cal i-1 

(parallel (trap-if (not-data-tLrpe? frame-function dtp-compi led-funct i on) 
genera 1 -ca I f-f unny-f unct i on) 
(funct ion-en try- instruct ion- fetch frame- funct ion) ) 

;Last place i^ page fault. Point PC points after the en^ry inctr. 
;If caller gave many args, onjy slow case of caltee applies 
;Otherwise cJispatch to appropriate cods for number of args 
;(^ote that the first two arguments" (self and sel f-mappmg- table) 
;have already been received. 
:; Sane timing comment applies as above 
(disoatch-af ter-next (Idb a-nargs 2 C) 
((0) (cal i-ind;rect-part-3 2 t)) 
(d) (ca! l-indirect-p2rt-3 3 t)) 
((2) (cal l-indirect-part-3 4 t))) 
(parat lei 

(trap-if (qreater-f ixnum a-nargs (b-consxant 2)) 
(paral lei 

(trep-no-save) 

(deciare-Tcmory-t f ming data-cycle) ;co,'ripiler check is conservative 
(if (rero-f ixnur?, (entry- instruct ion-di spatch memory-data) ) 
(sequent ic! 

(Keep-function-ni story call) 
(next-tnstruct icn) ) 
(signal-error-no-restore-stack wrong-number-of-argumu»nts) ) ) ) 
(tai'.e-di spatch))) 

; ; ; Lexpr call ing — -^ 

;rcstart-trapped-cal I wilt come back here. This is analogous to general-cat 1-1. 
(defucode restart-lcxpr-funcaU 

(parallel (trap-if (not-data-tupe? frame-function dtp-compi led-funct ion) 
general -cal i- funny- funct ion) 
(funct ion-entry-instruct icn-f etch frame-funct i on) ) 

;Last place to page fault. Point PC after the entry instr. 
(ncp) 

(keep-funct ion-hi storu call) 
(dispatch-after-next Tentry-instruct ion-di spatch memory-data) 

((9) (next-instruction)) ;Callee will do it himself 

;Here cailee does not want a rest argument. So this is either too 
;«any arguments, or need to call a support routine to pop some 
; arguments off the list, which is known not to be NIL. 
;Put in b-temp the maximum number of spread arguments the cailee wants. 
((1) (lexpr-funcall-fast 9 b-temp) ) 
((2 3) (lexpr-funcall-fast 1 b-ter;p)) 
((4 5 6) (lexpr-funcall-fast 2 b-terp)) 
((7 19 11 12) (lexpr-funcall-fast 3 b-temp)) 
((13 14 15 IB 17) (lexpr-funcall-fast 4 b-temp))) 
; Check for space in stack buffer 
(parallel (trap-if (greater-pointer stack-pointer stack-limit) 

(take- jump-trap stack-buffer-overflow-handler preserve-stack)) 
(take-dispatch))) 
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;Same for case uhere a method is being invoked and hence the first tuo "arguments" are there 
(defucode restart-Iexpr-method-cal I 

iparallel (trap-lf (not-data-type? frame- functi on dtp-compi I cd-f unction) 
genera t-cal I -funny- funct ion) 
(function-en try- instruct ion-fetch frame-funct i on) ) 

;L2st place to page fault. Point PC after the entry instr. 
(nop) 

(keep-function-history calf) 
(d i spatch-af ter-next Ic.^tru- i nstruct i on-di spatch Benory-data) 

((8) (next-instruction)) ;Cai lee ui I I do it himself 

;Here caltee does not want a rest argument. So this is either too 

:many arguments, or need to call a support routine to pop some 

;arguments off the list, which is known not to be NIL. 

;Put in b-ten:p the maximum number of spread arguments the callce wants. 

((1 2 3 4 5 7 8 11. 12.) ;ttust have at least 2 required arguments 

(sicnai-error-no-restore-stack wrong-number-of-arguments) ) 
((B) ( lexpr-funcall-fast 8 b-temp) ) 
(O. 18.) (lexpr-funcall-fast 1 b-temp)) 
((13. 14. 15.) (lexpr-funcall-fast 2 b-temp))) 
;ChecR for space tn stack buffer 
(parallel (trap-if (greater-pointer stack-pointer stack-limit) 

(take-iump-trap stack-buffer-overflow-handler preserve-stack)) 
(take-dispatch))) 

;Need to pull seme more arguments, and caller uses the fast entrg •equence, so 
:the PC isn't val id yet. 
(defuccde lexpr-funcat i-fast-trap 

(restart-pc restart-traoped-cai l-escape-pc) 

(para! lei (accept-restart-pc) 

(jump pul l-lexpr-args-no-restore-sp) ) ) 

;Come back here with stack containing number of unsuppMed arguments and return PC 
;in the case uhere there weren't enough elements in the rest arg to satisfy the 
;number of spread arguments the caltee wants. Turn into a normal call. 
;A couple of cycles could be bummed out of this code with some care. 
(definst un- I expr-funcal i no-operand 

(assign b-temp (1+ next-on-stack) ) ;Number of stack words to flush 

(pusnval frame-pointer) 

(assign b-temp-2 stack-pointer) ;Last word to preserve 

(assicn frame-pointer (- top-of-stack (a-constant 6))) ;-> rest arg, last tc flush 

(parallel 

(assign stack-pointer (- frame-pointer b-temp)) ;where that moves to 

(call bit-stack)) ; Squeeze out the extra spread args and the rest arn 

(parai lei » j 

(assign frame-pointer (- top-of-stack-a b-temp)) ;Restore fp 
(decrerrent-stack-pc inter) ) ; and restore sp 

(assign a-terp frsn-.e-number-of-args) ; Correct the frame's arg count 
(assign b-temp (- a-terp b-temp)) 
(assign frame-nuir.bcr-oT-args b-tenp) 
(assign frame-iexpr-called (b-constant 0)) 

tP^faliel rClean stack and jump to restart PC 

(assign next-on-stack top-of-stack-aJ 
(decrement-stack-pointer) 
(jump popj))) 

;;; Buncha random instructions 

(definst push-n-nils unsigned-imocdiate-operand ;l+2 cucles per NIL 
(parallel (assign b-temp (- (a-constont 8) Bacro-unsigned-iminediate) ) 
(jump push-mi ssing-vafuec) ) ) 

(definstl fixup-tos no-operand ;1 cycle 

(assign top-of-stack (amem (stack-pointer 0)))) 

(definst pop-n uns igned- immedi ate-operand ;2 cycles 

(parallel (assign stack-pointer (- stcck-pointer macro-unsigned-tmmcdiate) ) 
(jump fixup-tos))) 

(definst pop-n-save-1 (unsigned-immcdiate-operand needs-stack) ;2 cycles 
(assicn stacK-pointer (- stack-pointer macro-uns i gned- immediate) ) 
(parallel (assign (amem (stack-pointer C) ) top-of-stack) 
(next- instruct ion) ) ) 

(definst pop-n-save-m (uns igned- immediate-operand needs-stack) ;7+3n cycles 
(parallel (assign a-temp frame-pointer) 

(decrement-stack-pcinter) ) 
(parallel (assign frame-pointer (- stack-pointer tiacro-uns igned- immedi ate) ) 
assign b-temp-2 stack-pointer)) 



(paral lei (ass 
(cal . 
(paral tel (assi 



gn stack-pointer (- frame-pointer top-of-stack)) 

bit-stack)) 
gn frame-pointer a-temp) 



(next- instruct ion) ) ) 

(definst pop-mu! t iple-save-n una igned- immedi ate-operand 
(parallel (assign a-temp frame-pointer)) 

(parallel (assign frame-pointer (- stack-pointer aacro-unsigned-immediate 1)) 
(assign b-temp-2 stack-pointer)) ;Range to save 
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(assicn b-teirp (1+ (amem Hrame-pointer 6)))) tSize of multiple 

(parallel (assign stack-pointer (- frame-pointer b-tenip)) 

(cal I blt-stacK)) 
(parallel (assign frame-pointer a-terrp) 

(next-instruction) )) 

(def inst pcp-n-save-mu i t iple (uns i gned-immedi ate-operand needs-stack) 
(parallel (assign a-temp frame-pointer)) 
(parallel (assign frame-pointer (- stack-pointer top-of-stack 1)) 

(assign b-temp-2 stack-pointer)) ;Rance to save 

(parallel (assign stack-pointer (- frame-pointer macro-unsigned-iwmediate) ) 

(cal I fal t-stack)) 
(parallel (assign frame-pointer a-terip) 

(next- instruct ion)) ) 

(def inst pop-mul tip te-save-mult iple (no-operand needs-stack) 
(parallel (assign a-temp frame-pointer)) 
(parallel (assign frame-pointer (- slack-pointer top-of-stack D) 

(assicn b-temp-2 stack-pointer)) ; Range to save 

(assion b-temp U+ (amem (frame-pointer 0)))) ;Size of multiple 
(parallel (assign stack-pointer (- frams-pointer b-tei::p)) 

(cal I bit-stack)) 
(parallel (assign frame-pointer a-temp) 
(next-instruct ion)) ) 
;;; -»- Modetlisp; Packaoet flf cro: Base:8; Louercasezyes -«- 
;;; (c) Copyright 13S2» Symbolics* inc. 

; riicrocode for function cal I /re turn (part 2) 

; This file contains the instructions that functions 

; uith Bore than 4 arguments use to pick up their args. 

;Get defmicro and ail his hosts 

(declare (cond ((not (status feature Imucode)) 
(load 'udcls)))) 

;Random disorganized local reqtster definitions 
(reserve-scratchpad-memory 2418 2413) 

(defareg a-nargs) 
(defareg a-min-args) 
(defareg a-max-args) 

(def ine-b-temps b-save-fp b-nargs) 

:Note: a simplified version of this code exists at TAKE-REST-ARG* Keep them consistent. 
(defmicro genera I -take-args (min-args max-args opt ional-args? rest-arg^) 
* (sequent iai 

; Check for lexpr and method calls 
(di spa tch-after -next frame-argument- format 
( (Xf rame-arauments-norma I ) 

.•(general-take-args- internal titn-args «ax-args optional-args? rest-arg? nil)) 

( (Xframe-arguments- I expr) 

(puchval , (op nin-args Mb-constant 8))) ;Nutnber of required arguments 
(paral lei ^ 

(pushva! (set-type ,(if «ax-args :Number of optional arguments 

M- ,max-args top-of-stack-a) 
•(b-constant 8)) 
dtp-fix)) 
, ( t f rest-arg? 

'(call require-args-lexpr-rest) ;Returns if exact natch, stack pepped 
(jump require-args-lexpr-no-rest))) 
,«(if rest-aro? 

(general-take-args-internal min-arge nax-args optional-args? t nil))) 

( (Xframe-arguments-instance) 

(assign a-nargs (+ a-nargs (b-constant 2))) 

.•(gencral-take-args- internal min-args nax-args optional-args? rest-arg? t)) 

( (Xframe-arguments- I expr -instance) 

(pushval , (or Biin-args Mb-constant 8))) ;Number of required arouments 
(parallel 

(pushval (set-tijpe ,(if «ax-args ;Number of optional arguments 

*(- ,«iax-args top-of-ctack-a) 
* lb-constant 8) ) 
dtp-fix)) 
, (if rest-arg? 

'•(call require-args-lexpr-instance-rest) :Returns if exact natch, stack popped 
{ jump requ t rc-args- 1 expr- i nstance-no-rest ) ) ) 
,«((f rest-arg? 

'((assign a-nargs (+ a-nargs (b-constant 2))) 
,«(general-take-args-internal nin-args «iax-args optional-args? t t))))) 
;Get number of arouments supplied 
(paral lel 

(assign a-nargs frame-number-of-args) 
(assign b-naros frame-number-of-args) 
(take-dispatch)))) 
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^Entered with b-nar^s containing f rame-numbep-of-args, a-nargs containinn that 
;or that+ii m the nethod case, 
(eval-unen (eval load coroile! 

(defun gensrai-take-args-intcrnal (min-arge max-args opt iona l-args? rest-arg? method'? 
r^ ^ ^ ^3ux (b-side-reg 'b-nargs)) 

;Lheck for wrong number of args, increment PC by the number of optional 

;argunents that were supplied, put the nurrber of arguments to be 

;ccp(ed in the b-side register indicated by b-side-reg, leave the 

;nL;r.ber of argurrsnts supplied in b-nargs» and do all this in the 

tmtnimun: number of cycies. 

*{,%i\i (not opt ional-args?) 

(cond ((not rest-aro?) 

*((error-if Tnot-equa I -f i xnum a-nargs tffiin-args) wrong-number-of-arguner.ts) ) ) 
( tnot m 1 n-args) 
(setq b-side-reg nil) ;Nothing but a rest argument 

nil) 

( (not method?) 
(setq b-Ride-reg min-args) jCopy all the spread args 
((error-if ( i esser-f i xnum a-nargs .min-args) wrong-number-of-arqur -nt^) ) ) 
It (setq b-side-reg b-temp-2) 

M (assign b-terp-2 (- , min-args (a-constant 2))) ;2 arns alreadu ccnicd 
*( ^t ^ terror-if ( tesser-f i xnum a-nargs , min-args) urong-number-of-arcurnents) ) ) ) 

((not rect-arn?) 
M(errcr-if (nreater-f i xnum a-nargs .max-args) wrong-number-of-argurrcnts) 
,_*(cond (min-args ^ 

'((parallel 

(assign b-temp-2 (- a-nargo , min-args)) 
(error-if (lesser-f ixnum-unsigned a-nargs , min-args) 
urong-number-of-arguments) ) 
(assign PC (pc-p I US-number pc b-temp-2)))) 
((not method?) 
•((assign pc (pc-piua-number pc b-nargs)))) 

MCassiqn b-temp-2 a-nargs) 
,, . (assign pc (pc-plus-number pc b-temp-2))))))) 
( (not m I n-args) 
(setq b-side-reg 'b-temp-2) 
' l(p3ral \e\ 

(assign b-temp-2 a-nargs) 

(if (greater-f ixnum a-nargs .max-args) 

(sequential ;rest arg present 

(assign b-terp-2 ,«ax-args) 
(assign pc (oc-plus-number pc b-temp-2 1))) 
(assign pc (pc-plus-number pc b-temp-2)))) 
,«(if method? '((assign b-temp-2 (- b-temp-2 (a-constant 2))))))) 
(t (setq b-side-reg b-temp-2). 
' ( (para I iel 

(assign b-temp-2 a-nargs) 

(if (greater-f ixnum a-nargs ,max-aros) 

(sequential ;rest arg present 

(parallel (assign b-temp-2 ,max-args) 

(assign a-max-args ,max-args)) 
assign b-temp-3 (- a-max-args , min-args)) 
(assign pc (pc-plus-number pc b-tcmp-3 1))) 
(sequent iai 
(para) lei 

(assign b-temp-3 (- a-nargs ♦min-args)) 
(error-if ( (easer-f ixnum-unsi gned a-nargs , mi n-args) 
urong-nuBber-of-arguments) ) 
(assign pc (pc-pTus-number pc b-temp-3)}))) 
,m{\f method? '((assign b-tefflp-2 (- b-temp-2 (a-constant 2)))))))))) 
:Ue are now comT.itted to completing the instruction (PC chanaed) 
;However we cannot prefetch the next instruction, because that might 
;take a page fault and this instruction still has side-effects to do. 
;nake a-temp -> last argument, save the frame-pointer in b-save-fp 
(parallel (assign a-terp (- frame-pointer (b-constont 6))) 

(assign b-save-fp frame-pointer)) 
:Lopy up the arguments that were supplied, or some prefix of then, 
;blt-stack wants ftrst-1 in frame-pointer, last in b-temp-2 
;b-nargs st t 1 I has the number of arguments in the caller 8 frame 
.(cond t(eq b-stde-reg *b-n3rns) ;Copy alt the arauments 
(parallel (assign frame-pointer (- a-temp b-nargs)) 
(assign b-tefrp-2 a-temp) 
(cai I bit-stack))) 
((not (null b-side-reg)) ;Copy some of the arguments 
(sequential 

(parallel (assign frame-pointer (- a-temp b-nargs))) 
iparalfel (assign b-tefrp-2 (+ frame-pointer , b-side-reg) ) 
(assign s~ter^.p obus^ 
., icai \ bit-stscK)) ))) 

;Now handle rest argument if necessary, a-temp -> last normal arg 
;iT there are missing optionals. the defaulting of tho rest arg uTil 
; be dene by macrocode. But if there are no optional s we do it here. 
.(if rest-arg? 

^tRestore frame pointer, then decide whether there is a rest argument and push it 
(sequent i a I ^ r- 

(parallel (assign frame-pointer (set-type b-save-fp dtp-null)) 
( aratt I ^^^^^'^ a-pclsr-top-of-stack (set-type b-save-fp dtp-null))) 
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(assign b-terrp-2 (- a-narcts ,max-args 1)) 
(if i tesser-or-cqual-f rxnum-unsigned a-nargs ,fiax-apas) 
, ( i f opt lonal -args? 

* (next-instruct ion) 
Mparaitel (pushval quote-niO 
(next* instruct ion) ) ) 
(if (bit frame-lexpr-cal led) 
(if (zero-fixnum b-tep^p-2} 

;: exactly 83 rrany spread arguments as wanted, pass the rest arq 
(psrallei (pushval (amem (fratr.e-po inter -B))) ;Copu up rest ara 
(next-instruction)) ^-^ i- » 

:; Hore spread crgureents than uanted, rest arg points into them 
(sequent i a I 
;: Adjust cdr-code so normal rest argument list in the »tack 
;; tails off into lexpr arg 
(assign (amem (frame-pointer -7)) 

(sct-cdr (amem (frarc-polnter -7)) cdr-normal)} 
(parallel (pushval (set-type (1+ a-temp) dtp-list)) 
(next-instruction)))) 
:; Rest argument points into the arguments in the stack 
(seouent i al 

(assign (amem (frame-pointer -6)) 

(set-cdr (amem (frame-pointer -B) ) cdr-nil)) 
(parallel (pushval (set-type (1+ a-temp) dtp-list')) 
a ^ , (next-instruction))))))) 

;.Hestore frafe-pointer and exit 
'(parallel (ass.nn frame-pointer (set-type b-save-fp dtp-nul!)) 

(assign a-pclsr-tcp-of-stack (set-type b-save-fp dtp-null)) 
(next- instruct ion) ) ) ) ) ) 

(definst take-n-args uns igned- iwmediate-cperand 

(genera I -take-args macro-unsigned- immediate ni( nU nit)) 

(c^efinst take-n-args-rest unsigned- immediate-operand 

(general-take-args Bacro-unsigned-ianiediate nacro-unsigned-inimediate nil t)) 

;The operand is the number of normal arguments to be skipped before takina 
;the rest argument. Take NIL if there aren't that many. ^^'^^^ td^mg 
:jhe code here ts a oimpltfied copy of gsnerai-take-arqs since we are onlu takina one 
; The number ct arguments has already heen checked and fcurd to be lenai ^ 
:io L^*'"^2^ ^ Iexpr-c3ll, the recuire-args instruction will already 
:h3ve set up the rest arg properly. Je still have to check the number 
;of arguments in order to locate the rest arg. u..wtr 

(definst take-res t-arg unsigned- immediate-operand 
:; Get number of normal, spread arguments in a-naras 
(dispatch-after-next frame-arguwent-format 
( (Xframe-arauments-normal ) 
(parallel (assign s-nargs frame-number-of-aras) 
(iur:;p take-rest-arg-lJ J ) 
( (Xf rame-argunents- i expr ) 
(assiqn a-temp (1- a-temp)) 

(parallel (assign a-nargs (1- frame-number-of-arao) ) 
//-.z *J'^'^P take-rest-arg-lcxpr-l))} 
((Xframe-arguments-instance) 
{f!fir?J"'?^''^^ (t.^f^afne-number-of-args <b-constant 2))) 
(parallel *-^°- ' ^^^-?--f ixnu^^^^^^^^^ (a-constant 2) ) 

(jump take-rest-arg-1))) 
1 (Xframe-arguments- ( expr- i nstance) 
(assign a-temp (1- a-temp)) 

(assign a-nargs (+ frame-number-of-args (b-constant 1))) 
(parane. <error-,f <^-«-:|-u--!;|ned^«acro-^^ (a-con,tant 2)) 

(jump take-rest-arg-lexpr-1)))) 
:; a-terr.p gets pointer to last argument+1 
(para I lei 

(assign a.temD(- frame-pcinter (b-constant 5))) 
(take-dispatch))) 

(dsfucode take-rest-arg-1 
(par a I lei 

;Get the number of arguments that go into the rest arg 
lasstgn b-temp (- a-nargs macro-uns igned-immediat- 1)) 
;fcnough arguments for the rest argument to be embedded in the aros^ 
i.f greater-fjxnum-unsigned a-nargs macro-unsigned- immediate)^ 
(sequentta ;Yes. return pointer into caller's copy of aras 

(;lr;??el "^'^ (frame-po.nter -6)) (set-cdr (amera (f?lme-pSi^?er -6)) cdr-nil)) 

(pushval (set-type (- a-temp b-temp 1) dtp-list)) 
(next-mstruction)) ) 
(parallel (pushval quote-nil) 

{next-instruction))))) 

It's!! !^^I-**?*" "? ?** ^^"^^ a-nargs includes only the spread arguments 
'il2i' '2 ^'^^erent from how general-take-args does it. a^sui^ents. 
(defucode take-rest-arg-lexpr-1 

iparal lei 

f^!l:!!J®^"V'"^^'"/°* arguments that go into the rest arg 

.c"^[! b-temp (- a-nargs macro-unsigned- immediate Df 

jEncugh arguments for the rest argument to be embedded In the ara^r^ 

(.f (nreater-T.xnum-unsigned a-nargs macro-unsigned-immeSiate) ^ 
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(sequential ' -res, return pointer into cailer^s copy of arns 

assiqn amem (frame-pomter -7)) (set-cdr (amem (frame-pointer -7)) cdr-norral ) ) 
Ipara I le I 

(pushval (set-type (- a-tc/rrp b-temp 1) dtp-Itet)) 
(next-instruction) )) 
;Get^here if there were exactly the desired number of spread arguments. There 
;can t be fewer, because either the desired number i s fi or a require-args 
; instruction has been executed previously, 
(parallel (pushval (amem (frame-pointer -S))) 
(next- instruct ion) ) ) )} 

(definst take-n-opt iona l-args unsioned-tmffledi£*te-operand 
(general-take-args nil macro-unsTgncd-immcdiate t nil)) 

(definst taKe-n-opt ional-args-rest un&ioned- immediate-operand 
Igenerat-take-crgs nil macro-unsigned-imnediate t t)) 

(def inst take-m-required-n-opt ional-arns 

(cequ'^ntiai (unsigned-immediate-operand needs-stsck smashes-stack) 

*P?^!;|°1 ... * . . . . t^«* argument out of the uay first 

(cscjgn a-pclsr-tcp-of-stack top-of-stsck) 

(decrement -stack-pointer)) 
(gentral-take-orga tcp-ot-stack macro-unsigned-immediata t nil))*) 

(definst take-ir'.-required-n-opt i ona I -args-rest 

(sequential (unsigned- immedi ate-cperand needs-stack smashes-stack) 

^P^""^''^' jGet- argument out of the way first 

(assign a-pcl sr-top-of-stock top-of-»tack) 

(decrement-stack-pointer)} 
(general-take-args top-of-stack nacro-unsigned- immediate t t))) 

Check the number of arguments 

The stack contains the number of required arguments and the number of optional arouments 

(he immediate operand contains the number of rest arguments (1 or 8) 

In the case of a iexpr-cail. this fixes things up so take-srq doesn't have to check. 

if ypu re interested in optimizing thinas, change this into 

two mstruct ions, one with and one without a rest aroument, 

and avoid the need to copg arg count to B aide. Could either 

---pass one of the operandi through immediate, or use no-operand form. 
This says needs-stack although in fact it doesn't currently, 
definst require-args (uns i gned- immedi ate-operand needs-stack smashes-stack) 
Idi spatch-af ter-next frame-argumsnt-f crmat 
t (*frame-argumcnts-norma I ) 

(goto require-args-1) ) 
( (Xframe-arguments-lexpr ) 

(if (not-zero-f ixnum macro-unsigned-immedl ate) 
(goto require-args-fexpr-rest) 
^9^^o r equ i re-args- I expr -no-rest) ) ) 
( (*frame-arguments- instance) 
(para I lei 

(assign b-temp (+ frame-number-of-args (b-constant 2))) 
(jump require-arqs-D) ) 
( (*fr3me-arguments-!expr- instance) 

(if (not-zero-f ixnura macro-unsigned-inmediate) 
(goto r equ i re-ar gs- I expr- instance-rest) 
(goto require-args-lexpr-instance-no-rest)) ) ) 
(parallel 

(assign b-temp frame-number-of-args) ;Copy arg count to B aide 
(take-dispatch) ) } 

(defucode reguire-args-1 

Iparailel (error-if ( lesser-f ixnum-unsigned b-temp next-on-atack) 
wrong-number-of -argument a) 
(decrerrent-stack-pointer) ) 
(if (zerc-fixnum macro-uns igned-immedi ate) 
(sequent iai 

(assign a-temp (+ top-of-stack-a top-of-atack) ) ;naximum number of arguments 
iparaiiei .(^0 rest argument 

terror- (f (greater-f ixnum-unsi gned b-temp a-temp) 

wronq-number-of-arguments) 
(decrement-stack-pointer) 
(next- instruct ion) ) ) 
(p3-allel ^ ^ ^ . ^ ;Has rest argument 

(decrement-stack-DO inter) 
(next-instruction) ) ) ) 

:This function was lexpr-caMed. 

(defucode reaui re-args- I expr-no-rest 

;Thi£ function dees not take a rest argument, 
(asngn o-temp (+ ncxt-cn-stack top-of-stack)) 

;Need to pull some arguments out of the rest arg then try again 
(para i I e i s» » 

jassiqn b-temp (- b-temp frame-number-of-args)) 
(tf lesser-f ixnum-unsigned b-temp frame-number-of-args) 
signal -error wrong-number-of -arguments) 
(goto pu! l-lexpr-args)))) 
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(defucode require-args-Iexor-inetance-no-res.t 
;7his function does not take a rest arnument. 
(assign b-tewp (+ next-on-stack top-of-stack) ) 
tAireaJy cot two of them 
(assign b-ternp (- b-tcmp (a-ccnstant 2))) 
tNecci to pull sc^e arguments out of the rest arg then tru again 

lOSilnn b-temo (- P-temp fpame-nurr.tjer-of-args) ) 

(if (lesser-f ixnufn-unsioned b-tcnp frame-number-of-args) 

(si ana I -error urcnrj-number-of -arguments) 

(goto puM-texpr-argoJ J ) ) 

(defucode require-args-lexpr-rest 

;Thts function takes a rest argument. What ue want to do ts adjust the 
tnuRfcer of spread orauments so that it matches the number ue want, 
(parallel (assign b-tenp {+ next-on-stack top-of-stack 1)} 

(aecrement-stack-pointer) ) 
(if (equai^f ixnum frame-number-of-aras b-temp) 

(parallel (decrement-stack-pointer) ;Exact match 

(assign top-of-ctack tcp-of-stack-a) ;in case called fror.i general-take-args 
(next- instruct icnJ ) 
(droD-through)) 
(para I ler 

(trap- if (qreater-f ixnum-unsigned b-temp frame-number-of-args) 

;Not enough spread argunents. Pull some out of the rest arg and try again 
require-arcis-lcxpr-trap) 
(decrement -stack-pointer) 
(next-instruction))) 

(defucode require-arge- lexpr- instance-rest 

;Thi8 function takes « rest argument. Uhat we want to do is adjust the 
inuicber of spread arguments so that it aatchcs the number we want, 
(parallel (assign b-tenp (+ next-on-stack top-of-stack 1)) 

(decrewent-stack-po inter ) ) 
;Already got two of them 
(assign b-temp (- b-te«p (a-conatant 2))) 

V-! •^'act «iatch, no need to fixup. Note this can return to generaf-take-args code. 
(If tequai -f ixnum frame-nuraber-of-args b-temp) 

(parailel (decremcnt-stack-pointer) ;Ex3ct match 

(assign top-of-stack top-of-stack-a) ;in case called from Genera I -taka-args 
(next-mstruct ion) ) "^ 

(drop-through) ) 
(paral lei 

(trap- if (orc3ter-f ixnum-unsigned b-temp fratne-number-of-args) 

;Rot enough spread arguments. Pull soma out of the rest ara and tru aaain 
require-aras-iexpr-trap) » a 

(decrcment-stack-poTnter) 
(next- instruct ion) )) 

•u^^the^n^rm*^!*^^'"* '"*^*^^ °^ Qo\n^ directly to pul I -lexpr-args in order to speed 
(defucode rcau i re-args- 1 cxpr-trap 
(parallel (trap-no-savc) 

(ass ion b-temp (- b-temp frame-nu«iber-of-arqs 1)) 

(jump pul I- lexpr-args) )) 

;b-te«p has 1- the number of arguments to be pulled out of the rest ara. 
;First open space in the stack for them, then call a support routine to 
'5°^;^ ^^^^ ^"^ cdrs. The support routine will retry in one of two 
;different ways depending on whether the rest ara is exhausted 
(defucode pul T-iexpr-args 

(cal l-and-return-to restore-stack-poi nter put l-lexpr-args-no-rcstore-sp} ) 

(defucode pul I-lexpr-args-no-rcstore-sp 

(assign b-temp-2 (+ frame-number-of-args b-temp 1)) 
(assign frame-nurber-of-aros b-temp-2) 

(pushva! (set-tupe (1+ b-tcmp) dtp-fix)) ;Arqument to support routine 

\lll\Tn h^tSrri " frame-po inter (b-constant B))) ^ ;Bo?torword to^Sove {lexp?%rg) 
assrgn b-tem.p-2, (set-type (- stack-pointer b-temp-2) B)) jNumber of words to «ove-l 

assian frame-pointer (+ frame-pointsr b-temp D) -Shift frame upwards 
(parallel (assign stack-pointer (+ stack-pointer b-temp D) 
(assign b-temp-3 obus) 
(Jump pul l-lexpr-args-loop) )) 

:3 cycles per word moved. Probably net worth i»proving. 
(defucode pull- lexpr-args-ioop 

iassicn xbas (- stack-pointer b-temp 1)) 

(psrallel (assign (amem (stack-pointer 0}) (aaem (xbas 8))) 

(decrement-stack-pointer) ) 
(parallel (assign b-temp-2 (1- b-teiT;p-2)) 
(if (minus-f ixnum obus) 

(sequential (assign stack-pointer b-ten:p-3) 

/ * I. , ^^3*^®"?""^" trap pul I -lexpr-args preserve-stack)) 
(goto pul i-lexpr-args-loop)))) 

:lf!il ?k!!"°1* argument from the caller, by number, and push rt on the stack 
Wjote that .f we were lexpr-cal led. either all the arguments are there (and 
: maybe some more) , or else we turned into a non-tcxpr-cai U when a rcauire-aros 
;was done (it must be done before using this instruction). require args 

idefinst take-arq unsigncd-immediate-opcrand 
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;Get the distance doun from the last araumcnt+1, negated 

(assign b-temp (- macro-unsigned- immediate frame-number-of-args) ) 

;Get address of desired argument+6 

(assign jcbas (+ frame-pointer b-terp)) 

;Return it (but test for case uhere uc were called as a eethod, first arg is #2) 

(if (bit frame-instance-cal led) 

(paraiiei (pushval (amem (Kbas-7))) 

(next- instruct ion) ) 
(parallel (pushval (smem (xbas -5))? 

(next- instruct ion) ) ) } 

:0?TIGNAL-ARC-3L9PLIED-P — takes an inrrtediate aroument and pushes T if 

;more than that many arguments were supplied, cr UlL if they were not, 

Ti.e. the immediate operand is the zero-origin arnument number. 

;Th|s !S used to bind "flag variables", as in "fiOrllOrjAL (FGO BAR FOO-P)\ 

;Thi3 takes tuo cycles to execute. 

(def inst opt ional-arg-suppl ied-p unsigned-i Rimed late-operand 

(if ( lesser- fixnum-unsigned macro-unsigned- immediate frame-nuraber-of-aras) 
(para I lef * 

(pushval quote-t) 
(next- instruct ion) ) 
(paral lei 

(pushval quote-ni I) 
(next-instruction)))} 

F:>1mach>ucode>FUNCALLl.LISP.25 '^^ ~~' 

;;; -»- flodecLisp; PackanetHicro; Base:8; Lowercaserues -*- 
::: (c) Copyright 1982, Symbolics* Inc. 

; Microcode for function ca I t /return (Dart 2) 

; This file expands into thR various cati instructions 

: It is a separate fiic co macros can run compiled in the compiler 

;Get defmicro and all his hosts 

(declare (cond ((not (status feature Imucode)) 
( load *udcls) 
(load 'funcal I)))) 

iTrao handlers defined in SIPI 

(declare (special «stack-buf fer-overf low-handler») ) 

m 

(declare («expr funnu-^unct ion-trap-l ispraicrocode funcal l-funny-funct ion-trap-l i spmi crccode) ) 

;Having defined all the micros, now create all the CALL instructions 
;and their common defucode routines 
U, * ;heh, heh 
(proon * compi le 

..Tloop for nargs in ' (0 1 2 3 4 N) 

collect Mdefucode .(intern (format nit "CALL -INDIRECT-^- nargs)) 

tea! l-indirect-part-2 .nargs)) 
collect Mdefucode .(intern (format nil "CALL-H^IRECT-DISP— D" nargs)) 

(cal l-indirect-part-o , nargs)) ^ 

nconc 

(loop for value-disposition in •(ignore stack return wuttipte) 
col lect 

• (def inst .(intern (format nil "CALL— 0— A" 

,_ , nargs vatue-disposi tion)) 

,(if (eq nargs N) Mindirect-operand needs-stack) 
(indirect-operand)) 
(call-indirect ,value-di sposi t ion , nargs))))) 

;Also the FLfCALL versions 
t$, • ;heh. heh 
(proon ' compi le 

..Iloop for nargs in M8 1 2 3 A N NI) 

collect Mdefucode .(intern (format nil "FUNCALL-STACK-*.^" nargs)) 

(funcal l-stack-p3rt-2 .naros)) 
nconc 

(loop for value-disposition in '(ignore stack return multiple) 
CO I lect 

Mdefinst .(intern (format nil •FL^ALL-'vO-*A" 

nargs value-disposition)) 

. (seiectq nargs 

(MI 'unsigned- immediate-operand) 
(N • (no-operand needs-stack)) 
(otherwise 'no-operand)) 
(funcai l-stack .value-disposition .nargs))))) 

;Alsc the LEXPR-FUTOLL versions 
ff* ' ;heh, heh 
(proon * compi le 

..Iloop for value-disposition in Mignore stack return jbuI tiple) 
coi lect 
* (def inst .(intern (format nil "LEXPR-FUr,*CALL-vA" value-disposition)) 
uns i gned-imnedi ate-operand 
(iexpr-funcal I .value-disposition)) 



4,887,235 
381 382 

coi lect 
Mdefinst , (intern (format nil "LEXPR-FUNCALL-N-'^.A'' value-disposition)) 

(no-operand needs-stack? 
( lexpr-funcai i -n , va i ue-di spos j t ion)) ) ) 

F :>1mach>ucode>TuhTa^^^^^^ lisp. 142 ~~' ~ 

;;; -»- flodciLisp; PacKagetflJcro; Base:S; Lowercase:ycs -*- 
;;; (c) Copyright 1SS2, £ymi:oiics. Inc. 

; nicrocode for function cat I/return 

; This file contains just macro definitions for funcalll 

; (in a separate file so they get compiled) 

;Get defmicro and all his hosts 

(declare (cond ( (not (status feature Imucode) J 
(load 'udcls)))) 

(declare (*lexpr retch) ;in UU 

imey-or get-to-aipus get-to-ubus make-mi crodata) ;in irj 



(«expr cal l-indirect-disp-^- t i snn 
cai l-ind irect-di sp-l-l i spf? 
cal t-ind(rect-disp-2-I i spm 
cal l-tndirect-d) £p-3-t ispm 



crocodo : in FUNCALLl . 

crocode 

crocode 

crocode 



cat l-indirect-disp-4-I isprai crocode) ) 

(def-byte-f ield entry-instruct ion-di spatch XXentry-instruct ion-nrgs-di spatch source) 

;;: Function call and return — baste instructions 

:Trap handlers defined m STACX-BUFFEPf 

(declare (special *stack-buf fer-overf lou-hand!er«) ) 



;first instruction of tt, setting the VHA to point at it, starting a memory read, 
;and starting an instruction fetch. On the TDC ue mu^t be careful to be able to back 
;out if there is a paqe fault, and there are field-conflict problems. On the THC 
;and the mCS, we don t get to do a doubie-word instruction fetch because the following 
; cycle is using the spec field. 

;This micro Generates a mul tiple- instruct ion sequence, so be careful what you 
;put in parallel with it. 

(defmicro function-entry-instruction-fetch (function) 
(selectq utmachine-version* 
( (sin protc) 
Msequenttat (parallel 

, (get-to-cbus^Z function) ;Can't write VttA and Amem at same time 
(assign b-terrp obus)) 
(ass ion vma b-temp) 
(parallel 

(start-memory read instruction-fetch) 
(assign pc (odd-pc vma))))) 
( (tmc) 
'(sequential (assign vma .function) 

(start-memory read) ;Take page fault if any 

(assign pc (odd-pc vma)) ;Now th,:;t it's safe, set PC 
(start-iremory read instruction-fetch))) -Now read same loc acain 
((tmc5) 
Mscquential (parallel ;Load VHA, load PC, force to odd halfword 

(assign vma , function) 

(microinstruction spec ifu-control magic 1 «iagic-fflask 3)) 
(start-me::;cry read block instruction-fetch))) 
(otherwise (retch *'funct ion-entry- instruct ion-fetch needs to be written for -.S" 
»machine-version*) ))) 

;This micro stores a return-pc. On the TtiCB and IFU it takes an extra 1/2 cycle 
i because the PC has to be incremented. ( don* t see any way around this since it 
;ts realiu essential that the return-pc be the real PC to return to, not tho PC 
;of the call instruction. 

;Kludne: if pushing on the stack, sp assumed to be incremented in parallel 
(defmicro Etcre-reiurn-pc (place) 

(let {(ptaceZ (if (equal place * (amem (stack-pointer 1))) •(amem (stack-pointer 0)) placed) 
(selectq *ni3chine-version* 

((sin proto tmc) Mass. cin , place (set-cdr pc B) ) ) 

((tmcS ifu) '(parallel lassign .place iset-cdr (odd-nc (via-ybus pc) ) 0)) 

(if ininuo-f ixnum pc) ^Already oid. must increment 
(assign .place/ (set-cdr (cven-pc (i+ pc)) 0)) 
(arop-through) ) ) ) 
(otherwise (retch "store-return-pc needs to be written for ^S" *machine-ver8lon«) ) ) ) ) 

; Function call/return history kludge, to allow debug? i nq of transfers to randomness 

; Lhcose one of the two following definitions, to turn it on or off 

;Gff 

(defmicro keep-function-history (igncrc:) 
nil) 
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;0n 

(defnicro Keep-funct i cn-h i story (cp) 
(selcztq oc 

(r-L-rurr. Mcoi! keep- f u-nc t i on-re tur n-h i s tory) ) 
iza\ \' * (Ee':jer.t i a I 

Mcai ! keep- f-jnct icn-cal l-hl story ) 

(parallel (nop) jHore cmern address freedom 

(declare-memoru-tiininf^ (next d3ta-cucle) ) ) ) ) 
(cat I -funny '(call Xeep-funny-funct ion-cal 1 -hi story) ) 
(otherwise (retch '-^S i 1 legal type of function op" op)))) 

(defareg-at-loc funct fon-hi story-pointer 2700 1777772722) : Address of next history pair 

(defareg-at-ioc fhist-temp 27211 

;Locations 2702 through 2741 inclusive contain pairs as follows 

; function. cdr«0 for call, cdr*l for return 

; frame-pointer, 

(defucode keep-funct ion-ca! I -hi story 
(assign fhist-temp vma) 
(assign vma function-history-pointer) 

(store-contents frame-function block not-pointer (cdr 0)) 
(store-contents (set-type frame-pointer dtp-locative) block not-pointer) 
(if (area ter-po inter vma (b-constant 1777772741)) 

(assign function-history-pointer (b-constant 1777772702)) 

(assign function-history-pointer vma)) 
(parallel (assign vma fhist-temp) 

(jump memread))) ;Restore MD 

(defucode keep-funny-funct ion-cal 1-hi story 
(assign vma funct lon-hi story-pointer) 

(store-contents frame-function block not-pointer (cdr 0)) 
(store-contents (:-et-type frame-pointer dto-locat i ve) block not-pointer) 
(if (greater-pointer vma (b-constant 1777772741J) 

(assign funct ion-hi story-pointer (b-constant 1777772702)) 

(assign funct ior\-hi story-potntsr vmai ) 
(return) ) 

(defucode keep-funct ion-return-hi story 
(assign fhist-ter:p vma) 
(assign vma funct i on-hi story-pot nter) 

(store-contents frame-funct ton block not-pointer (cdr 1)) 
(store-contents (set-tupe frame-pointer dtp-locative) block not-potnter) 
(if (greater-pointer vma (b-constant 1777772741)) 

(assign function-history-pointer (b-constant 1777772702)) 
(assign function-history-pointer vma)) 
(parallel (assign vma fhist-temp) 
(return) ) ) 
) ; end commen t 

;Note that we now increment the stack pointer as we go, rather than 
; doing arithmetic on it at the end. 

{Nargs is a number from to 4, or N, meaning that it is on the stack. 
(defmtcro ca 1 I -indirect (value-disposition nargs) 
* (sequent ial 

»a(if (eg naras *N) ;Fooey» pop extra argument off the stack 
* ((parai lei 

(assign a-pc t sr-top-of-stsck top-of-stack) 
(decrement-stack-pointer) ) ) ) 
;Start read of pointer to function cell 
(assign vma (- frame-function macro-unsi gned-immediatc 1)) 

;Push previous-frame base pointer 
(parallel (start-memory read) 

(assign (smem (stack-pointer 1)) 

(set-cdr (set-tt_rpe frame-pointer dtp-locative) 0))) 
;Push previous-frame top pointer (-> arguments-1) 
;Cdr code is the value disposition 
(paral iel 

(assign (amem (stack-pointer 2) ) 

(set-cdr (set-type (- stack-pointer 

, (i f (eq nargs 'N) 
•top-of-stack 
* (b-constant ,nargs))) 
dtp- locat ive) 
, (f ind-posi t ion- in- 1 ist value-di spost t ion 
,. , ^ . , '(ignore stack return multiple)))) 

( increment-stack-pointer) 
(jump , (intern (format nil "CALL-INDIRECT--^*' narqs)))))) 

;Join common code for ail value dispositions this nargs 

(defraicro cal I-indirect-part-2 (nargs) 
' (sequential 

;Start read of function cell 
(parallel (declare-memory-t iming data-cycle) 
(transport) 

(check-data-tupe memory-data dtp-locative) 
(assign vma mimcry-data) 
( increment-sta;:k-pointer) ) 
;Store return pc 
(paral le! (start-memory read) 

(store-return-pc (amem (stack-pointer 1))) ;8p+3 
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( increment-stacK-pointer) ) 
;Stor5 mi EC fields word (just has nargs now) 
(parallel (assign (ameni (stack-pointer 1)) -sp+A 

(set-crfr (set-type .(if (eq nargs 'N) 'top-of-stack 

Mb-ccnstant .nsrgs)) 
dtp-fix) 8)) 
( increment-stack-pointcr) ) 

iStore the function, check type, set PC, start read of entry instr 
(paral le! (transport) 

(trap-if (not-data-tupe? itemory-data dtp-compi led-function) 

funny- f unct i on- trap) 
(assign (ameni (stack-pointer 1)) (set-cdr memory-data 8)) ;8p+5 
( increment-stack-pointer) 

(funct ion-entry- instruct ion-fetch memory-data) ) 
jPoint frame-pointer at first argument slot in neu frame 
xHou cannot pclsr, so we can clear a-pclsr-top-of-stack 
(parallel (assign frame-pointer (set-type (1+ stack-pointer) dtp-nut I)) 

(assign a-pclcr-tcp-of-stack (set-tyne (1+ stack-pointer) dtp-nult)) 
(ju:r.p , (intern (format nit *'CALL-IN0IRECT-D1S?— 0^ nargs))}))) 

(dcfmicro cal l-indirect-part-3 (nargs ^optional method-case) ;re9tart-trapped-C3l I enters 
• (sequent ial 

(keep- func t ton-hi story cal!) 
(parallel 

(declare-memory-t iming data-cycle) 
, ( i f (nufflberp nargs) 

' (scciuent ial tDispatch on entry instruction 

(dispatch-after-next (entry- mstruct ion-dispatch memory-data) 

. , (nargs-discatch-clauses nargs (if method-case 2 0))) 
; Check for space in stack buffer 
(paraUet (trap-if (greater-pointer stack-pointer stack-limit) 

(take-jump-trap stack-buffer-overf low-handler preserve-stack)) 
(take-dispatch))) 
• (sequent iai 

(error-no-restore-stack-i f 

(not (zero-f i>inum (entry-instruction-dispatch memory-data) 3 ) 
wrong-numbcr-of-argumcn'rc) 
(paratlet (trap-if (greater-pointer stack-pointer stack-limit) 

(take- jump-trap stack-buffer-overflow-handler preserve-stack)) 
(next- instruct ion) )))))) 

;Trap hp.re if calling something other than a dtp-compi led-funct ion. 

;The fur.c.iion was just read from memory and has not yet been pushed on the stack, 

;and the f rcine-pointer has not yet been set up. Otherwise the new stack frame 

;ts all buitt. Ue have not yet checked fcr stack-overflow, but that cnn be omitted 

;since this stack frame is very email, and we will check when we enter the escape 

'.function (or whatever we end up csiting). 

(de*'jccc^c funny-function-trap 

;fl3ke the new frame current, and clear pclsr top-of-stack flag 

(parallel k k j 

(trap-no-save) 

(dectare-memory-t tming (next data-cycle)) jFake out error-check 
(assign frame-pointer (set-type (+ stack-pointer (b-constant 2)) dtp-nul!)) : sp+S 
(assign a-pclsr-top-of-stack (set-tupe (+ stack-pointer (b-constant 2)) dtp-null))) 
; Store the random function into this frame 

(parallel (assign (amem (stack-pointer 1)) (set-cdr memory-data 2)) ;sp+5 
(increment-stack-pointer) 
(clear-stacK-adjustment) 
; Check for special cases 
(if (data- type? memory-data dtp-symbol) 
(goto funca I 1 -symbol ) 
(goto funny-funct ion-trap-1) ))} 

;Same, for case where we were doing funca M 
(defucode funcal I-funny-funct ion-trap 
;nake the new frame current, and clear pclsr top-of-stack flag 
(paral iel 

(trap-no-save) 

(assign frame-pointer (set-type (+ stack-pointer (b-constant 2)) dtp-null)) ; sp+6 
(assign a-pclsr-top-of-stack (set-type (+ stack-pointer (b-constant 2)) dtp-null))) 
;Store the random function into this frame 

(parallel (assign (amem (stack-pointer 1)) (amem (xbas 1))) ;sp+5 
( increment-stack-pointer) 
Icl ear-stack-ad j us tment) 
tCheck for special cases 
(if (data- type? (amem (xbas 1)) dtp-sumbol) 
(goto funca! I -symbol ) 
(goto funny-funct ion-trap-1) )) ) 

;Same for restarting a call (genera 1-caM-l) 
(defucode general -cal I -funny- funct ion 
;Check for special cases 
(parat Iel 

(trap-no-save) 

(if (data- type? frame-function dtp-symbol) 
(goto funcal I -symbol ) 
(goto funny-function-trap-1))}) 

;Here after the frame has been completely set up (all cases can join) 
^Handle any microcode dispatching, otherwise trap out to macrocode 
; Special code added here to allow breakpoint ing on calling various objects 
(defucode funny-funct ion-tr2p-l 
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(keep-funct ion-hiatory ca! l-funny) 
(if (data-type? frame-function dtp-instance) 
(ncto funcatl-instance) 

;f^ot a special case, go trap out to the interpreter 
(i.f (bit frame-instance-cal led) 

(take- jump-trap call-funny-method preserve-stack) 
(take- jump-trap ca M-funny-funct ion preserve-stack)) 
(if (data-type? frame-function dtp-closure) 
(goto funcal i -closure) 
(if (data-type? frame-function dtp-list) 
(goto funcai l-l i st) 

(if (data-type? frame-function dtp-array) 
(goto funca! l-array) 
(goto funcai l-random) }))) ) 

(defucode funca! I -closure 

(if (bit frame- instance-called) 

(take- jump-trap cai I -funny-method preserve-stack) 
(take-jump-trap cal i-funny-function preserve-stack))) 

(defucode funcai l-Itst 

(if (bit frame-instance-cal ied) 

(take- jump-trap cal 1 -funny-method preserve-stack) 
(take- jump-trap ca! t-funny-function preserve-stack))) 

(defucode funcai I -array 

(if (bit frame-instance-cal led) 

(take-jump-trap ca t l-funny-method preserve-stack) 
(taRC- jump-trap caM-funny-funct ion preserve-stack))) 

(defucode funcai l-random 

(if (bit frane-instance-cal led) 

(take- jump-trap call-funny-method preserve-stack) 
(take- jump- trap cal t-funny-function preserve-stack))) 

;Here when calling a symbol. Get its function cell without trapping out to microcode 

; Bum one cycle out of this when temporary memory control flushed 

(defucode funcai 1-symbot 

(restart-pc restar t-trapped-cal l-escape-pc) ;in case of page fault 
(paral lei (accept-restart-pc) 

(assign vma (+ frame-function (b-constant 2)))) 
(para! lei ( increment-stack-pointer) 

(call reference-sumoot-of f set) ) 
(parallel (assign frame-function (popvat)) 
(jump restart-trapped-cal 1))) 

;nake the disoatch table for function entru aiven number of args supplied. 
(defmacro ass- (a b) * (assoc Va 7b) ^ ;Fucking flaclisp 



(defun nargs-dispatch-ciauses (nargs arqs-already-there 
(let ((exactly (cdr (ass- nargs ^{{3 1) (1 3) 12 B) ( 
(too-few (cdr (ass- nargs '((S 3 5 S 8 9 10. 



3 10.) (4 15.))))) 
12. 13. 14, 15.) 
13. 14. 15.) 



(too-many (cdr (ass- nargs 



(optionais (cdr (ass- nargs 



(16 9 10, 
(2 10. 14, I5J 
(3 15.)J)>) 
'((1 1) 
(2 12 3) 
(3123456) 
(4 12 3 4 5 B 7 8 3 10.)))}) 
((0 (0 2) (0 4) (B 7) (0 11.)) 
(1 {0 2) (0 4) (1 5) (0 7) (1 8) 

(0 11.) (1 12.)) 
(2 (0 4) (1 5) (0 7) (1 8) (2 9) 
^ (0 11.) (1 12.) (2 13.)) 
(3 (0 7) (1 8) (2 9) ■ 
,^ (0 11.) (1 12.) (2 13.) (3 14.)) 

(or e«ct.. (retch ".S illegal va.it i? UrU'ri'^A' ''■' '' ^'•'^'"»' 
(((0) (next-mstruct icn)) -The slow cass 

.•(and too-feu '((.too-few 



; The slow case' 

(a«^ ♦«« «^« <signal-error-no-restore-8tack wrong-number-of-arguaents) ) ) ) 
(and too-many ' ( (, too-cianu a-^cMLa//// 



(^exact ly 
iparai Te 



-many 
(signal -error-no-res tore-stack wrong-number-of-arouments) ) ) ) 
, ^. , ;Ccpy this aany arguments 

(sequential 
. , (loop for i downfrom (- nargs crgs-already-there) above 

collect (pushval (anen (frame-pointer ,( 5 i)))))) 

(next-instruction))) 
, (loop for (n-required disp-code) in optionafs 
col lect * ((, disp-code) 

5) 



wrong-number-of-arguments) 



,(if (< n-required args-at ready-there) 
* (signal-errcr-no-restore-stack u 
•(parallel 

(sequential 
.•(loop for i downfron (- nargs args-a I ready- there) above 

CO M CC t 

(if (> (+ i args-a I ready-there) n-required) 

(setectq «machine-version« 
( (sim proto) 
' (sequentfal 
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(increment-fake-pc) 

{pushval (amem (frame-pointer ,(--5 i))})}) 
(otherwi se 
*(paral let 

(increment-pc) 

(pushva! (amem {frame-pointer ,( 5 i))))))} 

(pushvat (amem (frame-pointer ,( 5 i))}})) 

.•(if (> apga-ai ready-there n-required) 

;; Cannot do (increment-pc) and (next-instruction) 
:; in parallel. So take extra tine in case 

V/,"^*r?,?'' ^""Ss "ere optional and some supplied, 
((nop)))) 
(next- instruct ion) ))))))) 



» t » 



Funcall (with a variab/e function) 

The code is analogous to the above, but written sep.irately because 

ue aren* t overlapping uith funct ion-cel ( fetch. 



;nargs ts a number from to A or U (on stack) or Nl (imRcdiate) 
(deftticro funcal l-stack (value-disposition nargs) 
* (sequent ia) 

;PuEh previous-frame top pointer (-> funct ion-1) 
;Cdr code is the value disposition 
;Fushed out of order, note, 

;Also note that for -N variant, T05 is number of args 
; and there are allowed to bo 4 or fewer args 
.•(if (eq nargs 'N) ;Fooey, pop extra argur.snt off the stack 
'((parallel 

(assign a-pc!sr-top-of-5tack top-of-stack) 
(decrement-stack-pointer) ) ) ) 
(para I lei 

(assign (amem (stack -pointer 2)) 

(set-cdr (set-type (- stack-pointer 

, (selectq nargs 

(N *top-of-stack) 

(NI 'macro-uns i gned- immed i ate) 

(otherwise Mb-constant , nargs))) 

dtp- locative) 
, (f ind-posi t ion-fn-l ist value-disposi t ion 
'(ignore stack return multiple)))) 
(assign xbas obus) 
{ increment-stack-pointer) 
(jump .(intern (format nil "FUfJCALL-STACK--^" nargs)))))) 

;Join common code independent of value disposition 

(defmicro funcal l-stack-part-2 (nargs) 
'(sequential 

;Push previous- frame base pointer 
(parat lei 

(assign (amem (stack-pointer 0)) 

(set-cdr (set-type frame-pointer dtp-locative) 0)) 
( increment-stack-pointer) ) 
;Store return PC 
(parallel 

(stcre-return-pc (amefl (stack-pointer 1) ) ) 
(increment-stack-pointer)) 

;Store misc fields word 
(para I tel 

(assign (amem (stack-pointer 1)) 
(set-cdr (set-tupe 

, (selectq nargs 

(N '(+ (a-constant .(byte-mask frame-funcal led) ) 

top-of-stack)) 
(NI M+ (a-constant , (byte-mask frame-funcal led) ) 

macro-unsigned- immediate) ) 
(otherwise Ma-constant , (+ (byte-mask frame-funcal led) 
. ^ nargs)))) 

dtp-fix) 
0)) 
(increment-stack-pointer) ) 

;Store funct ion» check type, set PC, start read of entry instr 
(paral lei 

(assign (amem (stack-pointer D) (set-cdr (amem (xbas 1)) 0)) 
(trap- if (not-data-type? (amem (xbas 1)) dtp-compi led- funct ion) 

funcal I -funny-function-trap) 
(increment-stack-pointer) 
(function-entry-instruction-fetch (amem (xbas 1)))) 

. :Point frame-pointer at first argument slot in nsw frame 
;riow. having set the FC, we can dear a-pclsr-top-of-stack 
(paraMel (assign frare-pointer (set-type (1+ stack-pointer) dtp-null)) 

(assign a-pcisr-top-of-stack (set-type (1+ stack-pointer) dtp-nuID) 
(jurr.p .(selectq nargs 

(M *cal i-indirect-disp-N) 
(N *funcal l-stack-N-dispatch) 
(otherwi se 
; (intern (format nil "CALL-INOIRECT-DISP--^" nargs)))))))) 
;Join common code with call case 

;For funcall with a variable number of arguments, decide which case ue are 

(deruccde funcal t-stack-N-di spatch 
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tdisoatch. after-next (id.o top-of-stack 3 0) 

{(tJ) (goto cal l-indirect-disp-3)) 

{(1) (goto call-indirect-disp-D) 

((2) {goto cat l-fndircct-diEp-2) ) 

(i^) (goto cal t-inflirect-disp-3)} 

((A) (goto cal !-indirect-disp-4))) 
(paral let 

(trap-if (greater. fixnum-unsigned top-of-atack (a-constant 4)) 

(paral lel ( trcp-no-save) 
,^ ^ _,. ^^^ ( jurrp cal l-indirect-disp-n))) 
(take-dispatch))) 

;; Lexpr-funcal I (uit'h a v-ir table function, and a list of aros) 
;; The code is analogous to the aoovc, but written eeparately becauso 
: ; I am a turd. 

;; The number of spread aras ie tn macro-unsigned-immediste 
dcfmicro lexpr-funcal I (value-di cposi t ion) 
' (secuent iai 

;S3ve original top-of-stack in case us jump off to funcal 1-stack-n 

taccign a-pc I sr-top-of-stack tcp-of-stack-a) 

(ass.ign top-of-stack (1+ macro-unsinned-immediate) ) 

( lexpr-funcal l-part-i , value-di spost t ion) ) ) 

;The number of arge (spread plus 1 rest) is on the stack 
(defnicro lexpr-funcal l-n (value-disposition) 
* (sequent iaI 

(parallel (check-arg-tupe top-of-stack top-of-stack-a dtp-fix) 
(assign a-pclsr-top-of-stack top-of-stack) 
(decrement-stack-pointer) ) 
(lexpr-funcal l-part-1 , value-di sposi t ion) ) ) 

;Here top-of-stack has the total number of arguments (spread plus the list) 
;and the top thing on the stack ( top-of-stack-a) is the list 
(defraicro lexpr-funcal l-part-1 (vaiue-disposi t ton) 

;Push previous-frame top pointer (-> function-1) 
;Cdr code is the value disposition 
;Pushed out of order, note. 
Mparal lei 

(assign (amem (stack-pointer 2)) 

(set-cdr (set-type (- stack-pointer top-of-ctack 1) dtp-locative) 
, ( f i nd-pos i t i on- i n- 1 i st va I ue-d i spos i t i on 
, , '(ignore stock return aultiple)))) 

(assign xbas obus) 
( increment -stack-pointer) 
(jump iexpr-funcal l-part-2))) 

;Join comrr.cn code independent of value disposition 

;This is used below to handle the case where the caHee uses tha fact entry instruction 
tdetmtcro i^xpr-funcal l-fast (nargs-wanted dopt tona! (nar^a-place 'top-of-stack)) 
(psra Mr 

(error no-restore-stack-i f 

(iesser-f ixnum-unsinned (a-constant tnargs-uantcd) ,narqs-place) 
wrong-number -of -arguments) 
(assign b-temp (- (a-ccnstant .nargs-wanted) ,r.arg3-place) ) 
(jump lexpr-funcal l-fost-trap) ) ) 

(defucode lexpr-funcal l-part-2 
(sequential 

;First see if the rest arg is nil, to avoid dealing with 
:fencepost errors later. If it is. flush it and turn into 
tnormal funcal I . 
(parat lel 

(check-arg-tupe rest-arg (amem (stack-pointer -1)) dtp-liet dtp-nil) 
(if dat3-t'jpe? (amem (stack-pointe- -I)) dtp-nil) 

(sequential ;5qijec2e rest arg out of stack, turn into funcal l-n-dest 

assion (amem (stack-pointer 2)) (amem (stack-pointer 1))) 
(parallel (assign top-of-stack (1- top-of-stack)) 
(decrement-s tack-pointer) 

(jump funcal i-stack-n))) ' 

(drop-through) ) ) 

;Push previous-frame base pointer 
(paral lel 

(assign (amem (stack-pointer 3)) 

(set-cdr (set-type frame-pointer dtp-locative) 8)) 
1 increment-stack-pcintef") )} 
;Store return PC 
(paral lel 

(store-return-pc (amem (stack-pointer 1))) 
( incrfc;r.ent-stack-po inter) ) 

;Store misc fields word 
(paral lel 

(assign (amem (stack-pointer 1)) 

(set-cdr (set-type (+ (a-constant (+ (bute-mask frame-funcal led) 

(byte-mask frame-lexpr-cal led) ) ) 
tcp-of-stack) ;Mumber of args including rest am 
dtp-fix) 

1 1 ncrcment-s tack-pointer ) ) 

:Store function, check type, set PC, start read of entry instr 
ipara Me!. 

(assign (amem (stack-pointer 1)) (set-cdr (amem (xbas 1)) ^)) 
(trap- if (not-data-type? (amem (xnas 1)) dtp-cor;pi led-funct ion) 
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,, tunc 3 1 i-t"unnu-funct Ton- trap) 

( incremsnt-stacW-pointar) 
iiunction-entry-inctrLiCtion-fetth (amem (xbas 1}))) 

(parallel <^{^ l^ire^ol^nlrr '?i.';^tiJ.rprn?2^)?'°* '" "^" ^^^''^ 

(K^e%??un=??ir-hf^?ory-^l?f?,'"*-^'-^''° '^^ stacK-pointcr ) dtp-null)) 

»,,;rr,,t-h ,'9'*''^^'^'? ?" ^"*'"y '"=tfuction, maube do some work for callee 
'd EC3tch-after-nL-xt entry- .nstruct ion-di cpatch C!amory-d3ta) 

Ho' ''If -'"^*"^==^'°">' :Callee wilfdo it himself 

:here callee does not uant a rest argur.ent. So th,s is either too 
;Bany arguments, or need to call a support routine to pop sons 
;arguments off the list, uhich is knoun not to be NIL. 

Ul) nexpr!:Sncal I -fasrS) )"""''"" "' """"' ^^S^.ents the callee wants. 

((2 3) (lexpr-funcaM-fast 1)) 

((4 5 B) (lexpr-funcal l-fast 2)) 

((7 18 11 12) Hexpr-funcalf-fast 3)) 

((13 14 15 16 17) llexpr.funcat i-fast 4)}) 
^ ;Check for space in stack buffer 

Iparaliet (trap-.f (cireatcp-pointer stack-pointer stack-limit) 
(take-di5p3tchl/r^"^'"^^ «tack-buffep-over flow-handler preserve-stack) ) 



F:>lmach>ucode>FLOAT,LISP.33 

;;; .«- riodetLisp; Packane: Micro; Base: 8; Lowercase: yes -*- 
;:; (c) Copyright 13S2, Symbolics, Inc. 

;:;; Flonum microcode for 3608 

;:; Denorma I ized number representation: 



(def ine-enumerated-value-constants »f lonum-operat tons*) 



;:; airu 

:;; |1|- 

;;: IS 

;;; 31< 



Structure of "single** flonums 

cKpt frac 

3C:23> <22x^> 



<defsysbyte single-frac 23. 8) 
(defsysbyte single-N-b/t 1 23. J 
(defsysbyte single^expt 8, 23, i 
(defsysbyte single-sign 1 31,) 
(defsysbyte single-except-sign 31. 8) 

(cva i -when (eva I cowp i I e I oad) 

(defconst sinqle-exot-max (field-mask single-expt) ) 

(aefconst sing te-expt-bi as 127.) 

(defconst singie-expt-bias-ad just 1S2. ) 

}; eva t -when eva I coir.pile toad 

;:: Structure of internal sionificand ("frac") 
y^ ^ 

; ; ; ... V N , xxxxxxxxxxL G R S 
;;; ...2726 — <25:3>— 2 18 

;;; Uhere V is overflow bit, N is normalized bit, L is least-significant 
;;; bit of the significand, G is guard bit, R is rounding bit, and 
;;; 5 is sticky right-shift bit, 

(defsysbyte frac-S-bit 1 8) 

(defsysbyte frac-grs 3 0) 

(defsysbyte frac-round-di spatch 4 8) ;LGRS 

(defsysbyte frac-L-bit 1 3) 

(defsysbyte frac-field 23. 3) 

(defsysbyte f rac-f ie I d-denorma I ired 23. 4) -an extra bit over, since it has no N bit 

(defsucbyte frac-normal ize-di spatch 4 23.) ;highest bit is U 

(defs'jstyte frac-N-bit 1 26.) 

(defsysbyte frac-V-bit 1 27.) 

;:: Sore common constants, abbreviated here, 
(defmacro def ine-side-constants (side irest list) 
• (progn 'compi ie 

,•( loop for n in list 

collect * (defatomtcro ,(f intern "-vd^-ra" n side) 

,^ ,. .^ o , ,x (, (f intern "-a-CONSTANT" side) ,n))))) 

(def »ne-stde-constant5 a 8 1 -1) 

(def ine-side-constants b 1 2 33. 31. -1) 
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; ; ; ; f lonum-operat ing-mode 

(defsusDyte round mcj-mcde 2 1) 

(def-6yte-f ield rcunding-mode-wi th-inexact (3 1) rounding-modo-Bumble) 

; ; inexact-resui t nruEt be to lamedi ate ■ /ef t of rounding mode. See single-round-z. 

(eval-uhen (eval compile load) 

(dsfrracro def-rounding-mode-names (&rest pairs) 
(let* {(rm-names (loop for (name doc) in pairs 

collect (f intern -ROUNDING-rCDE-^a" name))) 
(pffi-ut th- inexact (append rm-nanes 

(loop for narao in rm-names 

collect (f intern "-a-INEXACT" name))))) 
(ppogn compt !e 

(def enumerated *rounding-mode-names« , rm-names) 

<defenumsrated *roundin9-mode-names-ui th-inexact« ♦rm-wi th-inexact) 
(def const »f lonum-roundtng-mode-doc-a! ist* 
' , i loop for { {) doc) in pairs 
for name in rm-names 
col lect M.doc . ,name)))))) 

(def -round ina-mcde-names 
(nearest "f^earest") 
(zero "toward zero") 



(plus "plus inf ini ty") 
(fliinus minus infinity"*) 



( 
) 

(assoclate-di spatch-cues round ing-mode «rounding-mode-nanes*) 

(asscciate-dispatch-cues round ing-mcoe-wi th-inexact *roundin3-mode-names-wi th-inexact*) 

(def ine-enumerated-vaiue-constants *rounding-iiodo-names*) 

(def ine-enumeratjd-value-constants «rounding-iiode-names-ui th- inexact*) 

(defconst *f lonum-trap-names* 

• ( (inexact-resu! t "Inexact Result") 

(invalid-operation "Invalid Operation") 

(overflow Overflou") 

(underflow "Underflow") 

(di visicn-by-zero "Division Dy zero"))) 

(defmacro def-several-bytes (prefix cof lection start names) 

* (progn * comp tie 

.•(loop for nawe in names 

for index « start then (1+ index) 

collect MdefsysDyte ,(f intern "^a-'^a** prefix name) 1 , index)) 
,«(and col lection 

M (defsysbyte., col lection , (length names) .start))))) 

(flef-several-bytes trao-enable trap-enables 3 

(inexact-result invalid-operation overftou underflow division-by-zero)) 

(def-several-bytes fiaq fisg-bits 8. 

(inexact-result invalid-operation overflow underflow di visron-by-zero) ) 

(def-several-bytes signal 13. 

(mexact-resul t invalid-operation overflow underflow division-by-zero)) 

(def-byte-f ield inf ini tu-mode (1 18.) inf tnt ty-mode-mumble) 

defenumerated *inf i n i tQ-mode-names* ( inf int tu-mode-af f ine inf ini ty-node-pro ject i ve) ) 
associate-diEsatch-cues inf ini tu-mooe *Jnf ini ty-mode-names*) 

(ocTconst *!nf ini tu-r.ode-doc-al ist* 

•(("Atfine" . inf jn( ttf-mode-af fine) 

("Projective** . inf mi ty-mode-project ive) ) ) 

;;;Tnese forms, e.g. (f i ag- inval i d-opcrat ion) , all take 2 cycles, but they 
;;;ne( called only in exceptional cases snywau. 
ff, • ipronn 'compi !e 

.suoop for condition in M" INVALID-OPERATIOrr "OVERFLOW" "LT^DERFLOU" "DIVISION-BY-ZERO") 
as flag-name - (fintern "FLAG— »a*' condition) 
collect Mdefmicro ,f leg-name 
' (parai lei 

(assign b-temo (dpb-ficid lea ,* flag-name 0)) 
(cat I f lag-f lonum-operat ing-mode))) 
as signal-name - (fintern "SIGNAL-'^a" condition) 
collect Mdefmicro ,signal-namo 
* (paral lei 

(assign b-temp <dpb-field l«a , * .sianal-name Z)) 
(ca1 I f Icg-f lor.um-operating-mode)))!) 

iir^:^*^;^?^,^ b-side constant because it gets called all the bloody time, and wants 

(defmicro f I ao- i nexac t-resu I t {) 

* (assign f lonum-opernt ing-mode 

(logtor f lonum-operat ing-mode (b-constant (field-mask f iag-incxact-recul t) ) ) ) ) 

(clefr::tcro s t ona I - i nexnc t-resu 1 1 

* (acs i gn f I onum-cpsrat i nrj-r.ioc^e 



(logicr ftcnun-bpcrat ing-mode (b-constant (field-mask si gna I - inexact-resu I t ) ) ) 



)) 
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(defmicro f lag-inexact-resul t-and-return 
' (para I le ! 

(f iag-inexact-resul t) 
(return))) 

(defmicpo si gna I -tnexact-resul t-and-trap O 

..^*llP.QM^^_rJtj:aPj-Ao-!?3.crocod (a i gna I - i nexac t-resu 1 1 ) f add-opero t i on) ) 
;;;; Sone general utility micros 

!:Thi8 should be Mparaliel (assign .foe .vaf) (if (f ixnura-rero obus) .«clau3es)) 
;;txcept that fixnun-zero uses an alu opDraticn. 

;;0f course, we have to do it tht» uaij anyuay since we can't check a/u cutout for 
;;2eroness, just for -Incss. ww^^^ul top 

(defmicro i f-zero-f (xnuin-assignment (pair 4bodu clau«es) 
(if (not (- (lenath pair) 2)i 

(ferror "Sad (loc val) pair in -vs" 

'rtf-zero-f ixnum-assignm-nt ,pair .oclausesM) 
(let (doc (first pair)) (vai (second pair))) 
* (sequent ial 

(assign , loc ,val) 
(if (zero-fixnuffi , ioc) 
.•clauses) ) ) ) 

(defmicro i f-Binus-f ixnum-assignnent (pair Abodu clauses) 
((f (not (• (lenoth pair) 2)1" 

(ferror () "Sad (loc vat) pair In -^^s" 
M ^ ,,, 'f if-zero-f ixnum-assignrrent .pair , •clauses))} 
(let (doc (first pair)) (val (second pair))) 
Uparat iel 

(assign , loc , val ) 
(if (minus-f ixnum obus) 
.•clauses)))) 

(defmicro Idb-regs (operand) 
•ddb .operand by te-s byte-r)) 

(defmicro f lonum-trap-to-macrocode (set-condition operation) 
(sequent > a I 
»set-condi t ion 
(par a I let 

(pushval (set-type .operation dtp-fix)) 
(jump push-z-and-trap-to-siacpocode) ))) 
;;;.Sonie temporaries, 

(reserve-scratchpad-memory 2413 2420) 

(def i ne-b- temps \ eave-space- f or-d i v i s i on-1 
i ca ve-space-for-divi ston-2 

x-expt ;wants to be on B side because of (Idb-field next-on-stack) 
x-frac :want5 to be on B sfds becaase of (dpb-field next-on-etack) 
y-sign ; wants lo be opposite next-on-stack. 
2-frac) ;on B because it gets replaced by byte operations on itself. 

(defareg y-expt) tuants to be on A side because of (Idb-field tcp-of-stack) , 

talso must be on different side from x-expt. 
(defareg y-frac) ;wants to be on A side because of (dpb-field top-of-stack) , 

jalso must be on different side from x-frac. 
(defareg z-sign) ;not importantly, see pack-and-return-z 

(defareg z-expt) ;probab!y on A because of hair in pack-and-return-z 

(defareg expt-diff) 

;;j; So«e FADD micros 

(defaicro fadd-adjust-y -7 cycles 
* ( sequen t i a 1 

(assign z-expt x-expt) 
(ass ion byte-r 8aa) 
(assign byte-5 (1- expt-diff)) 
(if (zcro-f ixnum (Idb-regs y-frac)) 
(sequent ial 

(assion byte-r (- expt-diff}) 
(paral Iel 

(assign byte-s (- 31»b expt-diffl) 
(if (r.iinuE-f ixnum obus) 

;; shifting to oblivion 
(assign y-frac 0aa) 
(assign y-frac (Idb-regs y-frac))))) 
(sequential 

(assion byte-r (- expt-diff)) 
(parai lei 

(assign byte-s (- 31«b expt-diff)) 
{(f (ninus-f ixnum obus) 

(assign y-frac (a-constant (field-mask frac-S-bi t) ) ) 
(assign y-frac (logtor (Idb-regs y-frac) 

(b-constant (field-mask frac-S-bi t) )))})))) } 

(defaicro fadd-ad just-x-neg .7 cucies 

'(sequential ' ^ 

(assign z-expt u-expt) 
(assign byte-r B«a) 
(assign byte-s (- -l«b expt-diff)) 
(if (zero-f ixnum (Idb-regs x-frac)) 
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Isequent iai 

(assign byte-r eypt-diff) 
(parallel 

(assign byte-s (+ 31«b expt-diff)) 
(if lminu9-f ixnum obus) 
(assian x-frac Bsa) 
(assign x-frac (idb-regs x-frac))))) 
(sequent la! 

(assign byts-r gxpt-diff) 
(paraT le! 

(assign byte-s (+ 31«b expt-diff)) 
(if (m inus-f i xnum obus) 

(assign x-frac (a-constant (field-tnask frac-S-bi t) ) ) 
(assign x-frac (logior (Idb-regs x-frac) 

(a-constant (field-nask frac-S-bi t) )))))))) ) 

(defmicro r iaht-shi f t-2-by-l () .3 cu-^les 
' (sequential 

(assign z-expt (1+ z-expt)) 

(if (field-bit 2-frac frac-S-bit) 

(assign z-frac (logior lea (Idb z-frsc 31, 1))) 
(assign z-frac (Ido z-frac 31. 1))))) 

(defiricro pack-and-return-z -A cycles 
(seauentiai 

(assign b-temp (Idb-field z-frac frac-fteld)) 

(assign b-terrp (cipb-fietd z-expt sinole-expt b-terp)) 

(sssion b-temp (dpb-field b-tetrp single-except-sign z-sign)) 

tpara Mel * =? 

(pop2push (set-tyoe b-temp dtp-float)) 

(next- instruct i on) ) H 

;;Uhen z-expt $ 0, dcnormal ize z-frac by right shifting -<z-expl> + 1 bits. 
■;Costs 1 cycle In normal case. 



(defmicro check-underflow (operation) 
'(if (plus-fixnura z-expt) 
(drop-through) 
(sequent i al 

(if (fieid-bit f lonum-operat ina-mode trap-enable-underf lou) 
(f )onutn-tr2p-to-wacrocode (si ana I -under f low) .operation) 
;:0k, if z-expt is -n, ue want to st icky-r inht-shi f t z-frac by n+1 bits. 
isequent tat '^ 

(f lag-under flow) 
(cal T normal ize-z) 
(assign byte-r 0»a) 
(assign byte-s (- 2»b z-expt)) 
(if (zero-f ixnum (Idb-regs z-frac)) 
(sequent iaI 

(assign byte-r (- z-expt i«b) ) 
(paral lei 

(assign byte-s (+ 38eb z-expt)) 
(if (m inus-f ixnum obus) 
(assign z-frac 0aa) 
(assign z-frac (Idb-regs z-frac))))) 
(sequent lal 

(assign byte-r (- r-expt l«b)) 
(parallel 

.. (assign byte-s U 38^5 z-expt)) 
(pf (minus-f rxnusi obus) 

(assign z-frac (a-constant (field-nask frac-S-bit))) 
(assign z-frac (logior (Idb-regs z-frac) 
(a«iBn z-expt 0.a)))))) <a-constant (field-pasK frac-S-bit)))))))) 

;;'"Thi;'I^''?he"ca«'^•N2S'S^c<^xpt"e'"'''"' ^'"' "=* denor«alized) result. 

xOve'-flow if expt > single-expt-max 
;;Costs 2 cycles in the normal case, 
(defmicro check-invalid-and-overf iou (operation) 
'(if (field-bit z-frac frac-N-bit) 

(if ( I esser-f ixnum z-expt (b-constant single-expt-max) ) 
(drop-through) 

(f lonum-trap-to-macrocode (signal-over f low) .operation)) 
iiirf'fc"! n?""^/^ unnormalized fraction. It's denormaiized (and hence, ok) 

(if (zero-fixnum z-expt) 
(drop-through) 
;;;: Ficnum add/subtract 
(defuccde fadd 
(paral lei 

( trap-no-53vei 

(assign y-sign top-of-stack) 

(jump f add-common) ) ) 

(defucode fsub 
(paral lei 

(trao-no-save) 
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(assign y-sion (loaxor -l«a top-of-stacK)) 
(jucp tada-coromcn) I ) 

(defuccde fadd-common 

{if-rcro-fixnum-assicjnment (x-expt {ldb-fie!d next-cn-stack sinqle-Exot) ) 
ass.gn x-frac (dpo-f ield next-on-stack frac-field-denornaliz^d en 
(if equal-f ixnum x-expt (a-constont s ingle-expt-f;:2x) ) 
(gcto T3dd-inf-or-nan) 

(assign x-frac (+ (b-constant (field-mask frac-N-bit)) 
f. , ,- {dpb-fiold next-on-stack frac-field 2))))) 

(if-rero-fixnum-asstgnment (y-expt (idP-field top-of-stack single-exot) ) 
if*}Hn. ^7^^-^ (dpb-f ield top-of-stack frac-f ield-denorinal zld 8?^ 
(if (equal-f.xnum y-expt (b-constant singfe-expt-max) ) 
(goto fadd-to-inf-or-nan) 
(sequential 

(assign b-temp (dpb-field top-of-stack frac-field 
(assign y-fracb-temp)))) ^^'""'^^"^ Cfield-^ack frsc-N-bi t) ) ) ) 
;:Adjiist 

(if-zero-f ixnum-asstonrrent (expt-diff (- x-expt u-exot)) 
(assign r-expt x-expt) ^ "pw/ 

(if (»inus-f ixnurc expt-diff) 
(fadd-adjust-x-nec) 
(fadd-adjust-y))) 
; ;Check s tens 

(if (not (minus-f ixnum (logxor y-sign next-on-etack) ) ) 
!;stons the same, add r.agnitudas 
(sequent iat 

(assign 2-stgn y-sign) 
(assign 2-frac (+ x-frac y-frac)) 
(if (fteld-bit 2-frac frac-V-bit) 
(right-shif t-z-by-1) 
(if (zero-f ixnum z-frac) 

(goto f add-resu I ted- i n-zero) 
(drop-throuoh)))) 
;:sign5 differ, subtract magnitudes 
(sequent iai 

(if (plus-or-zero-f ixnum y-sign) 

(assign r-frac (- y-frac x-frac)) 
(assign z-frac (- x-frac y-frac))) 
(if (zero-f ixnum z-frac) 

(sequent iaI 

(assign z-frac (- z-frac)) 
(assIg^'z-sTgXa)!)^^^ (field-«ask single-sign)))) 
;:Check whether input operands had been normalized 
(assicn b-tefrp (togior x-frac y-frac) i 
(tf (field-bit b-temp frac-N-bit) 
(cal I norma! ize-z) 
(drcp-throuqh)))) 
(check-uncerf low f add-operat ion) 
(cai i single-round-z) 

check-mval id-and-overf low f add-operat ion) 
(pack-and-return-z)) 
;;;; Normalization 

;;; Shift up to 4 bits at a whack, Ue try to pipeline soncthing useful 
;;; ui th take-dispatch, hence some of the hair here. Below. * represents 
;;;a ■icrocucie. (xxx;yyy) represents xxx and yyy done in parallel. 

:;; nain Aux 

;;; « Select dispatch « Select dispatch 

;;; « Take dispatch nt (Assign expt; Take dispatch, cane as at left) 

;;; C: * (assign frac; jump aux) 

;:: 1-7: » Assign frac 

;;; » (Assign expt; return) 

:;; 8-15: « Return 

; ; ; Ue para) lei 

(defmicro z-norma I ize-steps (num) 
'(sequential 

(assign z-frac (rotate z-frac ,nu!n)) 

(assign z-expt (- z-expt (b-constant ,num))))) 

;; This is a micro so it can be shared between normalizs-z an:i norma lize-z-aux 
;; next is the *'neyt" that follows di spatch-af ter-next 
(defmicro normal ize-z-dispatch (next) 
* (para I ie t 

Cdispatch-after-next (Idb-field z-frac frac-normal ize-di spatch) 
:;ut spatching on N.xxx 

HQ) xezdd 

(paral lei 

(assign z-frac (rotate z-frac A)) 
(jump norma! ize-z-aux))) 

(paral iel 

(z-nermat ize-steps 3) 
(raturnl)l 
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((2 3) -eaix 

Iparal iel 

(2-ncrma I ize-5teps 2) 
(return) )) 
((A 5 S 7) -eixx 

(para I le! 

(z-noririal ire-ateos 1) 
(return)))) 
Tif <greater-or-equa!-fixnuta-unsfgned (tdb-field z-frac frac-norsial ize-di spatch) 
; , . , , _ (a-conatant /?oia)) 

(para t t e ! , next (return) ) 
(paraliel ,next Uake-di spatch) ) ) ) ) 

(defucode norma! ize-z 

(norsal ize-2-dicpatch {))) 

(defucode norma lize-z-aux 
(norcal ize-z-di spatch 
lassign__z_-expt (- z-cxpt (b-constant 4))))) 
;;;; Rounding " " " "^ '^ 

(defmicro increment-z-frac-L-bf t (J 

• (sequential 



Cright-shif t-z-bu-1) 
(drcp-through)})) 

;;Ue di-spatch on rounding node combined uith th» ;rt*iwa,-+ ^«^..r* * 

::so ue dcn't have to 8c?eu around dwidinruhethi^'tfl'sp!"' *"*'^P"*"^'''° "'*' 

idefucode sinqle-pound-r 

(.f (equal-fixnuB (round i ng-«ode-u i th- inexact f lonun-operat ing-mcde) 
round ing-mode-nearest) wHcraung mooe; 

••Ue"Mn^*m?l^th^fp/n?^PA^?a 1° *'"'P °" Inexact-Result 

(return)) 
((12 3 4 tfoll ffol2 ffol2) .0031 opij, a^pf, ,pp. , -., 

(^'|9-»nexact-result.and-return ) • ^ * ^^^^' ^®^^* ^^^^ 
1(5 G 7 14 15 IS 17? ;eixx, lixx 

( I ncrement-z- f rac-L-b 1 1> 

id.epatch-after-thi, (rounding-«ode-uith- inexact f lcnur,-operat ing-„ode) 
TfrSJilJ^--^'''"^"""'^'""^ '' ^a"**" "re of by the IF above 
/ /o « A* mop) 

< 10) ^^ jeeco. I cos 

(return)) 
((12 3 4 #oll #ol2 ^ol3) :0e01. 00lx 0100 iRm 101 

5.anal.mexact-re3uit.and-trap)S • ^^^''' ^^^^' ^®^^' ^®^*^ 

( 5 S 7 14 15 16 17) ;01xx, llxx 

( increment-r-frac-L-bi t) 
/ t^J^l^^^ ' ■ ' nexact-resu I t-and-trap) ) ) ) 
( (round 1 ng-inode-zero) m^ / / / 

(tf (not-zero-fixnum (Idb-field z-frac frac-cr»)) 

flag-mexact-result-and-return) ^ 

(return))) 

( (round ing-mode-zero- inexact) 

lif not-zero-ftxnum (Idb-field z-frac frac-qrs)) 

srgnal-mcxact-resui t-and-trap) ^ 
(return))) ^ 

( (rounding-mode-plus) 

(if (pius-fixnu:n z-sign) 

(go to s i ng I e-round-z-up-noa i ana I } 

dm, ,nH°I° ® "]^ ' e-round-z-doun-nos i gna I ) ) ) 
I (round t ng-nodo-p I us- i nexact ) 
(if (plus-f ixnum 2-sign) 

(goto single-round-z-up-signsM 
tgoto singte-round-z-doyn-sinpat)}) 
( (round ing-mcde-m i nuE) 
Iff (plus-fixnum z-sinn) 

(goto s i ng I e-round-z-down-nos I ana I ) 
1^0 to s I no (ft-round-z-up-nos i gna I ) ) ) 
I round i ng-rnode-a 1 nus- i nexac t) 
l)f iplus-fixnum 2-S(pn) 

(goto s i ng I e-round-z-doun-s i cna I ) 
tgoto s i ng I e-round-2-up-8 i gna I ) ) ) ) ) 
(defucode s i nc; i e-round-z-up-nos i gna I 

itf zero-fixnum (Idb-field z-frac frac-grs)) 
(return) 
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(sequential 

( increment -2- frac-L-bi t) 
(f lag-inexact-resui t-and-return) ) ) ) 
(def ucode s i ng ! e-round-z-up-s i gna I 

(If (zero-fixnum (IciD-field z-frac f rac-grs) ) 
(return) 
(sequent iai 

( increment-z-frac-L-bi t) 
(signol-inexact-resui t-and*trap) ) ) ) 

(def ucode s i ng [ e-round-z-down-noe i gna I 

(if (zero-fixnum (idb-field z-frac frac-ars)) 
if laq-inexact-resul t-and-return) 
(retu-n))) 
(def ucode s i nr^ t e-round-z-doun-s i gna I 

(if (zerc-fixnum (ldb-fie!d z-frac frac-crs)) 
(si gna I - i nexac t-resu I t-and- trsp) 
(return) ) ) 



;;;; fadd exceptional cases 

jtHight as well save a ucode space word everywhere, as i.'^N. 
tdef ucode f tag-f lonum-cperat ing-mode 
(poral lei 

(assign f lonum-operating-irode 

^<logior f ionuw-operating-mode b-temp)) 
(return))) ^ 

(defucode fadd-resu I ted- in-zero 

(if (equal -fixnum (Idb-field f lonum-operat ing-mode round ing-r.ode) 
round i ng-mode-fti i nus) 
(assign z-sign (a-constant (fieid-mask single-sion) ) ) 
(assign z-sign 39a) ) 

■:lo min?«n«°Sa'[M2'^ 1^1 nornalized after binary point alignment, set the exponent 
,,to mmiauffl value, i.e., true zero. If neither was, leave the expt aione so 
U««"^rl'°" ^aP.^'fl occur when storing the result is attempted, 
(assign b-temp (logior x-frac y-frac)) -*.».Bmpicu. 

(if (field-bit b-tenp frac-N-bit) 
(para I let 

(pop2pu5h (set-type z-sign dtp-float)) 

(next- instruct ion) ) 

*** IplraTler"" ^""^'"^^ '''°^^ operands were zero 

(pop2push (set-tyce z-sign dtp-float)) 
(next- instruct icn) ) 
(f lonuf»-trap-to-«acrocode (s i gna I -under f low) fadd-operat ion) ) ) ) 

(defucode push-z-and- trap-to-macrocode 
(pushval (set-tupe z-frac dtp-fix)) 
(pushval (set-type z-expt dtp-fix)) 
(pushval (set-type z-sian dtp-fix)) 
(jump trap-to-Btacrocodel) 

(defucode fadd-inf-cr-nan 

( f I onum- trap. to-macr ocode (« i gna I - i nva I i d-oper at i on) fadd-operat i on) ) 

(defucode fadd-to-inf-cr-nan 

( f i onum- trap- to-macrocode ( s i gna I - i nva I i d-oper a t i on) fadd-operat i on) ) 

"'^::^P^X^l^^ts..o. f.oating-point-\rap.roTa"='.oro3"el? "^'*' '''''^ 
; : ; Scat ing 

;If there is anu exception, we just trap to the macrocoded ash, which is perhap9 wrong 
(defucode ash-float ^ k y 

;; First cneck for exceptional cases 

(if (zero-fixnum (Idb-field next-on-stack singte-exccpt-sign) ) ;Q,B or -0.0 
(para I 1 e I 

(pop2push next-on-stack.) 
(next- instruct ion) ) 
(drop-through)) 
(if (zero-fixnum (Idb-field next-on-Gt3::k singte-expt) ) 
(goto ash-overflow) 
(drop-through)) 

(if (equal-f ixnum ( I db-f i e I d next-on-stack s ingle-expt) (b-constant singlc-expt-max) ) 
(goto ash-over f tow) ^ ^ 

(drop-through) ) 

:; Scale the exponent 

(assign b-temp (+ (Idb-fietd next-on-stack single-expt) top-of-stack) ) 

(if (pius-ffxnum b-teffpJ 

(t' ( lesser-f ixnum b-temp (a-constant single-expt-max) ) 
iparal let a r 

(poD2puEh (set-type (dpb-field b-temp single-expt next-on-stack) dtp-float)) 
(next- instruct ion) ) 
/goto ash-over flow)) ; exponent overflow 

(goto ash -ove rflo w))) _^ ^exponent underflow 
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; ^ 5 4 

(defsusbute fmu I - 1 o- I ost 2B. 8) 
(defsusbyte f«ul-lo-take B 2G. ) 
(defsysbyte fmul-hi-take 21. 0) 
(defsysbyte fmul-hi-put 21. 6) 
(defsysbyte fsiuI-hi-V-bi t 1 21.) 

(defsusbyte fmul-to-ioat-V 27, 8) 

(defsysbyte fmul- lo-take-V 5. 27.) 

(defsysbyte fmul-hi-take-V 22. 0) 

(defsysbyte fmul-hi -put-V 22. 5J 

(defatomicro fmul-hi-part expt-diff) 
(dcfatoaicro fnul-io-part b-lou-dividend) 

;;tc pass to «py-32-32 which uants routines 
(defmicro fmul-store-hi-part (x) 

'(assign fmul-hi-part ,x)) 
(oefnicro fmul-store-lo-part (x) 

•(assign fwul -Jo-part »x)) 

(defucode fmu! 

(parallel (i f-rero-f ixnuw-assignment (x-expt I Idb-f ield next-on-stack single-expt) } 
(assign x-frac (dpb-freld next-on-stack frac-f ield-denormalized 0)) 
(tf (equal-f ixnura x-expt (a-constant single-expt-max) ) 
(goto fmul-inf-or-nan) 
(assign x-fpac (+ (b-constant (field-mask frac-N-bit)) 

idpb-fic id next-on-stack frac-f icid 0))) )) 
(tpap-no-save) ) 
(if-zero-f ixnum-assignment (y-expt (Idb-field top-of-stack stngle-expt) ) 
(assrgn y-frac (dpb-fietd top-of-stack frac-f ield-denormai ized 8)) 
{.' iequal-f ixnum y-expt (b-constant single-expt-nax) ) 
(goto fmul-to-mf-or-nan) 
(sequent iai 

(assign b-teirp (dpb-fteld top-of-stack frac-fiefd 

,,,, (a-constant (fieid-masK frac-N-bi t) ) ) ) 
(assign u-frac b-temp)))) 
(assign 2-sign (Togxop top-of-stack next-on-stack)) 
(mpy-32-j^ y-fpac x-fpac 

fmu I -s tope- i o-pap t fmu I -s tore-hi -pap t 

(if (field-bit fmu I -hi -part fmul-hi-V-bi t) 
(sequent iaI 

(assign z-expt (+ x-expt u-expt 1)) 

(if (zepo-fixnum (Idb-fieTd fmul-lo-papt fmul-!o-lo3t-V) ) 
(assign z-fpac (Idb-field fmul-lo-papt fmul-lo-take-V) ) 
(assign z-fpac (logiop laa (Idb-field fmul-lo-papt fmuI-lo-take-V))}) 
(assign z-frac (dpb-field fmul-hi-part f«ul-hi-put-V z-frac))) 
(seauential 

(assign z-expt (+ x-expt u-expt)) 

(if (zepo-fixnum (Idb-field fmu(-lo-papt fmul-lo-lost) ) 
(assign z-fpac (Idb-field fmui-lo-papt fmul-lo-take) ) 
(assign s-frac (logiop l«a (Idb-field f»ui-fo-p3Pt fmu!-!o-take) ) ) ) 
assign r-fpac (dpb-field fmul-hi-part fmul-hi-put z-fpac)))) 
(if (not-zepo-f ixnum z-fpac) 
(sequent iaI 

(assign z-expt (- z-expt (b-constant aingle-expt-bias) )) 
(check-under f I ou fmu I -operat r on) ) 
(assign z-expt C33) ) 
(ca! t single-pound-z) 

(check-inval id-and-ovepf low fmul-opepat ion) 
ipack-and-petupn-z)) 

(defucode fmul-inf-op-nan 

(dp!M°nrtrll^?'!°"'f'^?^°"^® (signal-invalid-opepation) fmu I -operat ion)) 
^IV^ ffui -to-mf-op-nan 
( f I onum- tpap- to-macpocode (s i gna I - i nva I i d-opepa t i on) fmu I -operat i on) ) 

;;divi£or is top-of-stcck (b) moved to u 
;;dividend is next-on-stack (a) moved to x 
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(eva 
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sysbyte fdiv-hi-take 17, 6) 
sysbyte fdiv-io-put 6 26.) 
i-when (evai compi ie load) 
const fdiv-hi-N-bi t (ash 1 17,)) 



;di vidend 



! dividend, upper 
;di visor 
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idefucode fdiv 

; ;hack the di vi sor 
(parai tel 

(ii-zero-f ixnum-assignrrent (y-expt (fdb-field top-of-9tack single-expt) ) 
(90 to fdi v-by-zerc-or-denorm) 

(if iequal-f ixnuia y-expt ib-ccnstant single-expt-nax) ) 
(goto fdi v-dy-inf-cr-nan) 
(sequent ia I 

(assign a-posi t i ve-di vi sor {/db-fie!d top-of-stack singfe-frac) ) 
(assign a-posi t i ve-di vi sor 

(logior a-po9i t ivG-divisor (b-constant (f ieid-aasK single-N-bi t) ) ) ) 
(assian a-negat ive-di visor (- a-posi t ive-divieor) ) ) ) ) 
(trap-no-save) ) 
;;hack the dividend 

(if-zepo-f ixnuffi-assignment (x-expt (Idb-f ield next-on-stack ainale-cxpt)) 
;; Divisor is normal, but dividend ia zero or denormaiized 
(if Crero-f ixnuffl (idb-fietd next-on-stack single-frac) ) 

:; Zero divided ty ncn-zero is zero, with xor of operands' signs 
(sequent iai 

(assign b-temp (dpb-fieid (b-constant 6) single-except-sign top-of-stack-a) ) 
(paraTie! (pop2pu£h (set-tyne (logxor next-on-stack b-terp) dtp-float)) 
(ncx t- instruct ion) ) ) 
;; Dividend Is denormaiized 
(^oto fdi v-into-dencrm) ) 
;; Dividend and divisor are normal 

(if (equal -fixnum x-expt (a-constant single-expt-max) ) 
(goto fdi v-into-inf-or-nan) 
(sequential 

(assign b-hi^h-di vidend 

(logior (tdb-field ncxt-on-stack fdtv-hi-take) 
(b-constant f di v-hi-U-bi t) ) ) 
(assign b-iou-dividend (dpb-field next-on-stack fdiv-Io-put 8))))) 
(para I lei 
;;15. « 32./2-1. see call to divide-routine in the DIVISION file. 
;; consider shifting operands to reduce this to 24,/2-l somehow, 
(assign a-divide-step-count (a-ccnstant 15.)) 

(call divide-subroutine)) ; leave quo in b-tow-dtvidend, and rem in b-high-di vidend. 
;;if there uas a remainder, set the sticky bit for rounding; and move to z-frac for 
' ;single-round-z, 

; figure a good uay to fold this m with the rounding?? 

if (not-zero-f ixnum b-hioh-di vidend) 

(assign z-frac (logicr b- tow-dividend (a-con»tant (field-mask frac-S-bi t)) ) ) 
(assign z-frac b-(ow-di vidend) ) 
;;If Quottent N-bit is zero, then left-shift quo by 1 and deer its expt 
(if (field-bit b- low-dividend frac-N-bit) 
(assign z-expt (- x-cxpt y-expt)) 
(sequential 

(assign z-expt (- x-expt y-expt 1)) 
(assign z-frsc (rotate z-frac 1)))) 
(assign z-expt (+ z-expt (b-conatanf single-expt-bi as) ) ) 
(ass:gn z-stgn (logxor next-on-stack top-of-s tack) ) 
(chcck-underf low fdi v-operat ion) 
(ca 11 8 i ng I e-round-z) 

(check- inval id-and-nverf low fdi v-operat ion) 
(pack-and-return-z) ) 

(defucode fdi v-by-zero-or-denorm 

( f I onuiR- trap- to-macrocorie (si gna 1 - i nva I i d-opcrat i on) fdi v-opsrat i on) ) 
(defucode fdi v-by-inf-or-nan 

Hic.-um-trap-tb-racrocode (si gnal - inva I id-operation) fdi v-operat ton) ) 
(dotucode fdi v- into-dcnorm 

( f i ::num-trap-to-macrocode (si gna 1 - i nva I t d-operat i on) fdi v-operat i on) ) 
tdefucode fdi v-into-inf-or-nan 

(fionuB- trap-to-macrocode (signal -inval id-operation) fdi v-op erat ion) ) 

;;; Convert ftxnum on top of stack to ftonum on top of stack 
;;;Traps to macrocode aren't rea/ly going to work, yet, 

(cvat-tihen (eval compile load) 

(defconst »5etz-as-f tonum* ;setz here being -1 31. 

(dpb-field 1 sinnle-sign * 

(dpb-field T+ single-expt-bias 31.) single-e«pt G) ) ) 
): eval -when eval-compi te-(oad 

(defucode convert-f ixnum-to-f lonum 
(if l»inus-f ixnuri top-of-stack) 

(if (zcro-fixnum (Idb top-of-stack 31. 0)) ;set2? 
(parai lel 

(newtop (set-typo (b-constant «5etz-3s-f Icnum*) dtp-ftcat)) 
(return)) 
(sequential 

(assign z-sign (b-const^nt 1 31.)) 
(assign b-temp (- top-of-stack)))) 
(if Jzero-ftxnum top-of-stack) 
(parai lel 

(newtop (set-type (b-constant 0) dtp-float)) 
(return)) 
(sequent tat 

(assign z-sign (b-constant 0)) 
(assign b-temp top-of-stack)))) 
(if (zero-fixnum (Idb b-temp 4 27.)) ; the bits above frac-n-bit 
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;;they are zero, no sueat 
(sequent iai 

(assign z-expt (b-ccnstant (+ single-expt-bias 2S.)}) ;2S. is hou far to shift 1 -• N 
(assign r-frac b-temp)) 
;;some bits up there, need to chlft right by 4 to clear then 
(sequent i ai 

(assign 2-expt (b-constant (+ single-expt-bias 25. 4))) ;ye8 
(if (zero-f ixnuni (idb b-te^.p 4 C) ) :is sticky bit sdiustrient necessaru'? 
(assign z-frac (Idb b-tcfrn 23. 4)) ;no 

(assign z-frac (logior i\Co b-ten^p 28. 4) (a-ccnstant 1)))))) 
call nprwalire-z) ;burn a couple cycles here somehow? 

cal I £ ingse-round-z) 

assign b-temp (Idb-field z-frac frac-field)) 
(assign b-temp (dpb-fieid z-expt singie-expt b-temp)) 
(assign b-temp (dpb-field b-temp single-except-sign z-sign)) 
(parallel 

(neutop (set-type b-terrp dtp-float)) 
(return))) 

;;; Compare flonums: Returns oositive number if the first is grrjater than the second 
:;; negative number rf the second is greater than the first, and if they are eaual 
(defucode f lonum-compare ** ^hwoi 

(if (zero-fixnum ( tdb-f ie id next-on-stack tingie-expt) ) 

(assign x-frac (dpb-fJeld next-on-stack single-frac 0)) 
(assign x-frac next-on-stack)) 
(if (zero-fixnura (idb-fiefd top-of-stack-s single-expt) ) 

(assign y-frac (dpb-field top-of-stack-a single-frsc 6)) 
(acsian y-frac top-of-stack-a)) 
(if (eauaT-f.xnum jldb-field next-on-stack singlo-expt) (b-constant single-expt-aax) ) 
(gclo compare-f irst-inf-or-nan) -i ^ ^^ 

(carop-throuah) ) 

*'^ !!2^f';Ii::C'''" t'clb-field top-of-stack-a singie-expt) (b-constant single-expt-max) ) 
(goto compare-second- I nf-or-nan) ^ ^ 

(drop-through) ) 

v,^^'? *^'"^P '* because of signed magnitude lossaae 
(tf (mmus-fixnum x-frac) 

(if (minus-f ixnum y-frac) 

;; Both negative, larger if xfrac < y-frac 

(parallel (pop2push (set-type (- y-frac x-frac) dtp-fix)) 

_ (return) ) 
;; First is neoative, second is positive 
(parallel (pop^oush (set-type (b-constant -1) dtp-fix)) 
(return))) 
(if (minus-f ixnum y-frac) 

;; First is positive, second is negative 

(parallel (pcp2pu5h (set-type (b-constant 1) dtp-fix)) 

(return)) 
;: Both positive faroer \f x-frac > y-frac 
(parallel (pop2pu£h Iset-type (- x-frac y-frac^ dtp-fix)) 
(returnii))) 

(defucode fgreaterp 

\llu'\VonuT.lUlrtr°-''''''' ''="""°* "" ■'" ^'^"^ ^y='- «^t«- ^--aP 

(if (plu2-fixnum top-of-stack-a) 
(noto truel) 
(goto falsel))) 

(defucode flessp 

(?an'l?inu"-§ii%r"°-"^^^' '^^""»* "" '" ''''' =«='• ^^*«- ^-aP 

(if (minu3-f ixnum top-of-stack-a) 
(goto truel) 
(goto falsel))) 

(defucode feaual 

(?lM'i!inu."!?i.iI?r"°-"^"' '^^""°* "" - ^-'^ ^Wcie after trap 

(if (zero-f ixnum top-of-stack-a) 
(goto truel) 
(goto fsisel))) 

;;; Signum of flonums: 

UlfucSdl fsicnum*^^ ^^^^^^ function, since it returns a fixnum, not a flonum) 
(if (zero-fTxnum (Idb-field top-of-stack-a si ngle-except-sign) ) 
(parallel neutop (set-type (b-constant 8) dtp-fix)) 

(return)) 
(drop-throunh) ) 

'■" (|ot=';^nri^i^S;!;ii? toP-°^-tacK-a smgie-expt) (b-constant »ingle-expt-«ax)) 

(drop-through) ) 
(if (rrinus-f ixnum top-of-stack-a) 

(parallel (neutop (set-type (b-constant -1) dtp-fix)) 

(return) ) 
(parallel (neutop (set-type (b-constant 1) dtp-fix)) 
(returr.}}} ) 

;;; IhnraSnent'exceprSi^h'z^r'S" '" '"«""'" "" "°* ^'S"""' ""* J"»^ •'«*"^"«'^ 

(defucode fplusp 
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Cparallef CnopJ ftrap-no-£3ve) ) ;Cannot cail In first cycle after trap 

leal I fs ignum) ^ 

{if (plus-fixnum top-of-stack) 

{goto truel) 

(goto falsel))) 



(defucode fminus 



sTucocae rminusp 

(parallel (nop) (trap-no-save)) 

tea! i fsignum) 

(if (ninus-f ixnum top-of-stack) 

(goto truel) 

(?oto falsel))) 



;Cannot call in first cycle after trap 



(defucode fzerop 

(ca'lt'isinnCm?* ^^^^P'^^-save) ) ;Cannot call in first cycle after trap 

(if (rero-f ixnuffi top-of-stack) 
(acto truel) 
(goto fatsel))) _ 

(defucode minus-flonum 
(paral lei (trap-no-save) 

(if (equal-f ixnum (Idb-ficfd top-of-stack-a stngle-expt) 
(p-constant singte-expt-cax) ) 
(goto «inus-inf-or-nan) 
(drop-through))) 
(parallel (neutcp (set-type (logxor (b-constant (fteld-aack single-sign)) 

top-of-stack-a) 
dtp-f l03l)) 
(next- instr u ct ion) )) ^^„.__^ 

F:>lmach>ucode>f livor. 1 1 sp. 25 

;;; -«- HodetLisp; Packaqerflicro; Base:8; Lowercasetyes -*- 
;;; (c) Copyright 13S2, Symbolics, Inc. 

; Microcode for flavors 

:Get defaicro and all his hosts 

m 

(declare (cond ((not (status feature tiiucode)) 
(load *udcis)))) 

(reserve-scratchp3d-»e«ory 2452 24G0 3^5 351) 

;Data on the most recently used mapping table (an ART-1C3 array) 
(defbreg b-c3ched-mapp ing-tab Ic) 
(defareg a-cached-mapp ing- tab I e-addrecu) 
(de f areg a-cached-napp i ng- 1 ab i e-s t ze) 

(defatonicro self 

(amem (frame-pointer 8))) 

(defatomicro sel f-mapptnq-tabie 
iamen (frawe-po inter 1))) 

<def i nst push- i nstance-var J ab ! e-ordered uns i gned- 1 itmed i ate-operand 
(parallel (check-arg-type instance self dtp-instance) 

(aemread (+ self »acro-uns i gned- iamedi ate))) 
(parallel (transport data) 

(pushva I ■ettort^-data) 

(next-'mstruct ion>)> 

(de f i ns t . Bovem- i nstance-var t ab t e-ordered (uns i gned- i «Bied t a te-operand needs-stack) 
(parallel (check-arg-type instance self dtp-instance) 

(memread T+ self «acro-uns i gned- i«medi ate) ) ) 
(parallel (transport write) ;Fol lou any forwarding pointer 

(assign a-temp jtlerge new data with old cdr code 

(werge-cdr top-of-stack anemory-data) ) ) 
(paraMei (store-contents a-temp) ;Now write back the new car 
(next- instruct ion) ) ) 

(definst pop- instance-variable-ordered (uns ianed-ianedi a te-operand needs-stack) 
(parallel (check-arg-type instance self dtp-instance) 

(assign vtna U self nacro-unsigned-iUMediate) )) 
(parallel (start-Menory read) 

(assign b-temp top-of-stack)) 
(for-effect (popval)) 
(parallel (transport write) ;Fol!ow any forwarding pointer 

(assign a-temp cflerge new data with old cdr code 

(merge-cdr b-temp memory-data))) 
(parallel (store-contents a-temp) ;Now write back the new car 

(next- instruct ion) ) ) 



(de f i nstl push-address- i nstance-var i ab I e-ordered uns i gned- i tmcdi ate-operand 
tcheck-arg-type instance self dtp-instance) 
(pushval (set-type (+ self macro-unsi gned- immed late) dtp-locative))) 



;8 cycles if the mapping table is already encached 

; Additional 11 cycles to encache it if necessary 

;Uould fce 7 cycles with no range check and assumed simple array format, thus no ancaching 



4,887,235 
415 416 

tdeftnst push-mstance-var labfe unsignetf-mmecliate-oporancf 

(p3ral lei 

(checK-arg-type sel f-mapping- table self-mapping-table dtp-array) 
(call-select (equal-typed-pointer sei f-mapping-table b-cached-Biapprng-tab!e) 
fast-mapping- table- lookup slou-mapping-taDle-lookup)) 
(start-memory read) 
(nop) 
(parallel (transport data) 

(pushva i memory-data) 
(next- instruct ion) ) ) 

(definst movem- instance-variable (unsigned- immediate-operand needs-stack) 
(parai lei 

(check-arg-type se t f-mapping-tab te sel f-mapping-table dtp-array) 
(cat I -select (equai-typed-po inter set f-mappi ng- table b-cached-mapoing-table) 
fast -mapp i ng- 1 ab I e- 1 ookup s I ou-napp i ng- tab i e- 1 ookup) ) 
(start-memory read) 
(nop) 
(parallel (transport ur ite) ;FoIlow any forwarding pointer 

(assign a-terrp tdargs new data with old cdr code 

(fflerge-cdr top-of-stack memory-data))) 
(parallel (store-contents a-temp) ;Now write back the new car 
(next- instruct ion)) ) 

(definst pop- instance- var iab I e (unsigned-tmir.ediate-operand needs-stack) 

(para I I e I 

(check-arg-type se I f-mapping-tah le self-mapping-table dtp-array) 
(call-eelect (equol-typed-pointcr self-mapping-table b-cached-mapping-table) 
, ., , , fast-mappmg-table-looKup slow-mapping-table-lookup)) 
(parallel (start-memory read) rt- a p 

(assign b-temp top-of-stcck) ) 
(for-cHect (pcpval ) ) 
(parallel jtranEport write) jFoIlow any forwarding pointer 

tacsinn a-terr.p jHerge new data with old cdr code 

(»erge-cdr b-temp memory-data))) 
(parallel (store-contents a-temp) -Now write back the new car 
(next- instruct ion) ) ) 

(def inst push-address- ins tance-var iabie unsigned-inaediate-operand 
(para I lei 

(check-arg-type sel f-mapplng-table sei f-mapptng-table dtp-array) 
(ca! l-select (equal-tuped-pointer eel f-tnapping-tabic b-cached-mapping-table) 
f ast-napp i ng- tab 1 e- 1 ookup s I ou-mapp i ng- tab I e- 1 ookup) ) 
(parallel (pushvat (set-type vma dtp-locative)) 
(next- instruct ion) ) ) 

(de f ucode s I ow-mapp i ng- tab I e- 1 ookup 

(parallel (check-arg-type self-mapping-table sel f-mapping-table dtp-array) 

(assign vma self-mapping-table) 

(assign b-vma sel f-mapping-toble) 

(cal / array-setup-ld-rero) ) 
;(trap-if (not-rero-f (xnurs top-of-st£ck) (signal-error "Index offset not handled")) 
:(trap-if (not-equal-f ixnura (array-register-dispatch-f ieid (amem (stack-pointer 1))) 
; , . ^ ^rray-register-dispatch-lS-bit) 

,; (signal-error "flapping table must be art-l£b")) 
(assign s-cached-mappfng- table-address (amew (stack-pointer 2))) 
(assign a-cached-mapping-tab le-size (amea (stack-pointer 3))) 
(assign b-cached-mapping-table set f-mapping- table) 
(parallel (assign top-of-stack top-of-stack-a> 

( junp fast-mapping- table- I ookup))) 

(de f ucode f as t-mapp i ng-tab I e- 1 ookup 
;; Divide the instance-variable number by 2 and access the art-lGb array 
(assign vma (+ a-cached-mappt ng-tab I e-address (rotate macro-unsigned- immediate 37))) 
;; Range-check the instance-variable number 
(parallel (start-memory read) 

(error-i f (greater-or-equai-f ixnum-unsigned macro-unsigned- immediate 

a-csched-mapp i ng-tab 1 e-s i ze) 
»3ppmg-tabte-out-of-bounds) ) 
;; Extract the appropriate ha if word, put instance-variable address into VMA 
(paral lei 

(check-arg-type instance self dtp-instance) 
(assign b-teirp sel f ) 

(if (Tdb-bi t-test macro-unstgned- immediate 0) ;oddp 

(mach i ne-vers i on-case 
((trac tmcS) (sequential 

(assign a-temp memory-data) 
(assign vma (+ b-terp (Idb a-temp 28 28))))) 
(otherwise (assign vma (+ b-temp (Idb memory-data 28 28))))) 
(machi ne-vers ion-case 
((tmc tmc5) (sequential 

(assign a-temp memory-data) 
(assign vma (+ b-temp (I do a-terr.p 28 0))))) 
(otherwise (assign vma (+ b-temp (Idb memory-data 28 8))))))) 
;This could check for instance-variable-number out of range, but that would 
;requ(re accessing another field in the instance deccriptcr. The flavor sustera 
;fs not supposed to let that happen. But instance variable zero is really 
;accessed when an instance variable is deleted or only existed at compile time, 
(para Met 

(error-i f (equal-pointer vma b-temp) instance-variable-zero-referenced) 
(return))) 
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(def ine-stcrage-uopd-offset-constants instance-descriptor) 

;; Vr.A has the address of an instance. Return its sire in a- temp. 
(defucDde instance- size 

(start-memory rend) jFetch inctance-deccr iptcr 

(nop) 

(parallel (transport header) 

(r.achine- vers ion-case 
((tnc ttncS) (sequential 

(assign a- temp mepory-data) 

(aesign vrr.a {+ a-temp tinst3nce-descr iptor-sire) ) ) ) 
(otherwise {assign vxa (+ ncroory-data tinstance-descr iptor-size) ) ) ) 
(ca! 1 mcmread) ) 
(parallel (declare-memory-timing data-cycle) 

(chcck-arg-type instance-sire «eniory-data dtp-fix) 
(assign a-tentp memory-data) 
(return) ) ) 

(defrnst !Cinstance-ref unsigned-immediate-operand 

(parallel (check-arg-type instance tcp-of-stack-a dtp-instance) 

(assign vma top-of-stack-a) 

(cal I instance-size)) 
(error- ( f (greater-f i xnum-unsigned nacro-unstgned-immedtate a- temp)' 

illegal-subscript) 
(parallel (assign vma (+ top-of-stack-a Mcpo-unsigned-immediate)) 

( ju:r,p newtppmem) )) 

(definst Xinstance-loc unsigred-intmedrate-operand 

(parallel (check-arg-typs instance top-of-stack-a dtp-instance) 

(assign vma top-of-stack-a) 

(call instance-sise) ) 
(error- if (greater-f i xnuw-unsigned »3cro-un8igned-i«»edi ate a-temp) 

iliegaf-subscr ipt) 
(parallel (newtop (set-type (+ top-of-stack-a •acpo-unsigncd-i«mediate) dtp- locative)) 

(next- instruct ton) ) ) 

(definst t instance-set unsigned-imfflediatc-operand 

(parallel (check-arg-type instance top-of-stack-a dtp- instance) 

(assign vma tcp-of-stack-a) 

(ca 1 I i nstance-s i re) ) 
(error- if (oreater-f ixnum-unsJgned Racro-unstgncd-iamediate a- temp) 

i 1 legat-subEcr ipt) 
(parallel (asstrn vrria (+ top-of-stack-a ftacro-unsigred-iiimediate)) 

(decrement-stack-pointer) 

(jump popmem))) 

(defareg a- instance-descriptor) 

(defareg a-hash-table) 

(defbreg b-nessage) 

(defbreg b-sel f ) 

(defareo a-hash-table-l iini t) 

:Come here when calling a function that turns out to be an instance 
(deijcode funca! 1-instance 

(restart-pc restart-trapped-cal l-escape-pc) ;in case of page fault 

(paral lel (accept-restart-pc) 

(assign vma frame-function) -Get the instance descriptor 

(assign b-vaa frame-function)) 
(start-memory read) 
(if (not (bit f irst-part-donc)) 
(sequent iai 

(parallel (transport header) 

(assign a- instance-descriptor »emory-data) ) 
(assign vma (+ a- instance-descriptor Xinstance-descr ip tor-bind inns) ) 
(parallel 

(start-memory read) 

(assian frame-function («et-tupe b-v»a dtp-instance) ) ) ; fol low-structure-fcruarding 
(pushvaT (set-type (a-constant 1) dtp-fix)) ; index of instance variable slot 
(paral let 

(pushva! memory-data) ;Btndings list 

(transport data) 

(check-arg-type instance-binding-table •emory-data dtp-list dtp-nil) 
(if (data- type? •etaory-data dtp- list) 
(paral let 

(assign frame-nt sc-data 

(logior framc-Bisc-data (b-constant (+ (byte-nask frame-rnstance-cal led) 

(byte-mask first-part-done))))) 
(clear -stack-adjustment) 
(jump funca I l-instance-b/nding-foop) ) 
(paraf Jel 

(assign f.-ame-mi sc-data 

(logior frame-ai sc-data (b-constant (+ (byte-mask frame-instance-called) 

(byte-mask first-part-done))))) 
(c 1 ear-stack-adjustment) 
(jump funca 1 l-instance-part-2) ) ) ) ) 
(parallel ;Here when restarting after pclsr 

(transport header) 

(assign a-instance-descr tptor memoru-data) 
(jump funca 1 l-instance-binding-loopf) ) ) 

(defucode funcal !-instance-binding-loop 
(parallel (assign vma top-of-stack-a) 
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(if (not (data-tupe? top-of-stack-a dtp-l ist) ) 

(goto funcal r-instance-part-2) ;Pclsred after binding-loop finished 
(aroD- through) ) } 
(star t-mencru read) 
(assign b-self frame-function) 
(paraliei (transport) 

(checK-arg-tupe instance-binding Bemory-data dtp-fix dtp-Iocat i ve) 
(assign b-temp memory-data) 
(assign a-hash-ta&le memory-data) 
(if (data-type? memory-data dtp-fix) 

;; Skip over some instance variable slots 

(assign next-on-stack (set-type (+ next-on-stack b-t«mp) dtp-fix)) 

:; Bind this cci t 

(sequent iai 

(pushval (set-type (-*• b-self next-on-stack) 

dtp-ex terna I -va I ue-ce I t -po i nter ) ) 
(paral let 

(assign vma a-hash-table) 
(cal 1 "oind-top-of -stack-closure) ) 
(assign next-on-stack (set-type (1+ next-on-stack) dtp-fix))))) 
;; a-hash-tabie still has the uord from memory, check the cdr code to see if we're done 
(parallel (neutop (set-type (1+ top-of-stack) dtp-list)) 
(if (cdr-code? a-hash-tab!e cdr-next) 
(goto funcal l-instance-binding-loop) 
(paral lei 

(newtop quote-nil) ;Flag that we're done binding 

(junp funcat l-in8tance-part-2))))) 

;At this point, all of the bindings have been done, two words have been pushed on the 
:stack (but their contents is oarbage) , and first-part-done is set. Find the 
'Bri^? ^tile for the flavor, (The non-hash-tabte case has been punted since 
;StLF IS not a special variable and would not get bound.) 
(defucode funcal I -instance-par t-2 
;; Set a-hash-taole to the hash table 

(memread (+ a- instance-descr iptor Xinstance-descr iptor-funct ion) ) 
(paral lei (transport) 

(check-arg-type instance-hash-table memory-data dtp-array) 
(assign a-hash-tsble memory-data)) 
'i ■ X /"^*^*?®. "^""^^ arcjument (the message keyword), put it in b-message 
(if not (bit frame-lexpr-cal led)) « ' ►- y 

(sequent iaI 

(error-tf ( I esser-f ixnum-uns i aned frame-number-of-args (b-constant 1)) 

wrong-number -of -arguments) 
assign b-terp f rame-number-of -aras) 
(assign xoas (- frame-pointer b-temp)J 
(assign b-message (amen (xbas -S) ) ) ) 
(if (greater-or-equa I -f ixnum-uns igned frame-numbcr-of-args (b-conctant 2)) 
(sequential 

(assign b-temp frame-number-of-args) 
(assign xbas (- frame-pointer b-temp)) 
(assign b-message (amem (xbas -5)))) 
(sequent ial 

(memread (amem (frame-pointer -B) ) ) 
(paral let (transport) 

(assign b-messaQG memory-data))))) 
;; The hash-table is a short-leader array, with a i-tjcrd prefix and a 4-uord leader 
;; ]h6 first 3 elements are; mask, undef ined-message-handlcr, gc-aenerst ion-number 
ass.gn vma (+ a-hash-table (b-constant 5))) ;Get the nast^ 
(start-memory read) 

If.ltl^'^J'^tl*!:!^^^^ i* a-hash-table (b-constant (+14 3)))) ;Start of actual hash 
(parallel check-arg-tuoe mstance-hash-tabfe-entry mcniorLj-data dtp-fix) 
(assign a-temp memory-data) 
(assign b-tetnp memory-data)) 
assign b-temp-2 (+ a-temp (dpb b-ter.p 31. 1 8))) :nask times 3 
(^ara??e? ''■'''"' ^ a-hash-xable b-temp-2)) 
llJli'in altemC obSf))' ^'-'""S^ ^"^^^P^^ :»ask symbol with mask 

lUrllVr?^^^^^^^ =-t'P'y t^3t by 3, use as hash 

(assign b-temp obus) 
(jump funcal l-instance-hash-loop))) 

(defucode funcal l-instance-hash-looo 

(parallel 

(start-memory read) 

(trap-if (greater-pointer b-temp 3-hash-table-l imi t) 
(paral lei 

(trap-no-save) 
(assign vma a-hash-tabie) 
(assign b-temp a-hash-table) 
(jump funcal l-instance-haoh-Ioop)))) 
(ass I an b-self frame-function) 
(parallel (trap-if (data-type? memcru-data dtp-nil) 

, (goto funcal l-instance-hash-raisa)) 
(assign a-temp memory-data)) 
(if (cqual-tuped-pointer a-temp b-message) 
(goto funcal l-instance-hash-win) 
(paral lei 

(assign vma (+ vma (b-constant 3))) 
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(assign b-te^p cbus) 

(jump funcal 1 -instance-hash- loop) )) ) 

(defu-^de funca! i-tnstance-hash-»i ss 
(parallel (trap-no-save) 

(assign sc t f-marjp tng-tab I e gucte-ni!)) 
(ffiemresd (- a-hash-tabie (b-constanl 2))) ;Get miss handler 

(paralici (transport) 

(assign frame-function «cniory-data)) 
(assign sel f b-se 1 f) 
(parallel (assign first-part-done (b-constant 0)) 

(jump restart-trappcd-cal l})} 

(defucode funcal l-instance-hash-win 

(mcffiread (1+ vma)) -Get the napping table 

(parallel (transport) 

(assign sel f-wapping-tabie eemory-data) ) 
;; If it pclsrs here, eei f -mapping-table isn't a list so it won't 
;; thrnk it's a binding list and go try to do bindings 
(memread (1+ vma)) ;Get the method 

(para* tel (transport) 

(assign frame-function memory-data)) 
;Cannot pclsr any more, finish up 
(assign sel f b-sel f) 
(parallel (assign first-part-done (b-constant 0)) 

(jump restart-trapped-cal I))) 

F :>1mach>ucode>DIvrSI0M . LISP . 34 

;;: -«- node:Li5p; Packaoernicro; BaserS; Louercaseiyes -»- 
::: (c) Copyright 19S2, Symboncs. inc* 

; Microcode for division 

;Get defmtcro and all his hosts 

m 

(declare (cond ((not (status feature fmucode)) 
(load 'udcis)))) 

;Te«porary storage 

ireserve-scratchpad-memory 2434 2A37) 

idefareg a-posi t I ve-di vi sor ) jHagnitude of divisor 

(defareg a-negat ive-di vi sor) ;2*8-complement of that 

(befareg a-divide-step-count) ;NuBber of bits over 2 minus 1 (counts doun) 

(define-b- temps b-high-dividend ;£nds up with remainder 
b-(ou-di vidend) ;Ends Up with quotient 

:Given dividend and divisor on the stack, set up internal variables 
(def micro integer-divide-setup (index ^optional float-version) 
'(sequential 
(parallel 

(check-binary-arithmetic-operands-fast no-operand , index nil , float-version) 
(assign b- low-dividend next-on-stack) 
(if (minu5-f ixnum next-on-stack) 

(assign b-tou-dtvrdend (- next-on-stack.) i 
(drop-through) ) ) 
(parallel (assign b-high-divtdend (b-constant 0)) 
(cal I divisor-setup)))) 

;TRUNC2 instruction takes dividend «ncf dJvtsor on the stack, 
; returns truncated quotient and remainder on the stack. 

; — This code needs to be bummed, it uastes 5 whole cycles 

(definst trunc2 no-operand 

(integer-divide-setup Xar i th-op-di vide) 

(call t-unc2- interna I) 

(assign next-on-stack sQuotient 

(set-cdr (set-type b-low-di vidend dtp-fix) cdr-next)) 
(parat lei 

(neutcp (set-type b-high-dividend dtp-fix)) ;Remainder 
(next-instruction) ) ) 

;;: This is necessary because for floating point calculating remainder is expensive. 
;;; Therefore the compiler generates calls to these instructions if possible 
(definst quotient-stack no-operand 

{ integer-divide-setup *ar i th-op-di vide fdiv) 

(ca t I trunc2- i nterna I ) 

(parallel (pcp2push (set-type b-lou-dividend dtp-fix) ) 
(next-instruction) ) ) 

(definst remainder-stack no-operand 

( integer-di vide-setup Xar i th-op-remainder) 
(call trunc2- interna I ) 

(parallel (pop2push (set-type b-high-dividend dtp-fix)) 
(next-instruction) ) ) 

(defucode trunc2-internal 

(call divide-subroutine) ;0o the division 
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;Now coirpute results, usmg truncate mode 

(if tplus-or-2ero-f ixnum next-on-stack) ;Check sign of dividend 
(if (plus-or-zero-f ixnum top-of-stack-a) ; and of divisor 
(return) 

(parallel (assign b- low-dividend (- b-Iow-di vidend)) 
(return))) 
(sequent iai 

(if (p I us-or-zero-f ixnum top-of-stack-a) 

(assign b- I ou-di vidend (- b- low-di vidend) ) 
(errcr-if (mi nus-f i xnum b-l ow-di vidend) 

unimplemented-ar i thmet ic) ) ; 

(parallel (assign b-high-di vidend (- b-high-di vidend)) 
(return))))) 

;Given divisor at the top of the stack, and dividend already set up, 
; finish setting up the division, 
(defucode divisor-setup 

(parallel (assign a-posi t i ve-dl vi sor top-of-stack-a) 
(if (mi nus-f ixnum top-of-stack-a) 

(assign a-posi t ive-divi sor (- top-of-stack-a)) 
(drop-throunh) ) ) 
(parallel (assign a-negatTve-divi sor (- a-posi t ive-divi sor) ) ) 
(parallel (assign a-divide-step-count (a-constant IB, ) ) 

(return))) ;15-32/2-l, see call to divide-routine 

5° f2 divide steps in a loop unrolled n-steps ways, 2 cycles per bit, 
ulv]Uc-n-AuJ-b IE the nth (from the end) step for ghen we should add, 

because we subtracted too much last time, where b (e or 1) is the 
n?^?A-'^'^r^S shift in from the tow half of the dividend. 
^ >, i:'£-'^-r-''°"'^ 'S ^^^ S^SP ^^^ when we should subtract. 
uivlot-n-ul IS the second cycle of the step, with a quotient bit of 1. 

DIVIOE-n-Q0 is the second cycle with a quotient bit of 0, 

(defwacro divide-routine (n-steps) 
'(progn 'ccmpi le 

. ,(looD for step downfroB n-steps above 8 

col lect 

• (defucode ,(f intern "DIVIDE-'vO-SUB-e* itcD) 

(parallel 

(assign b-high-di vidend 

(;* imiJl a-negative-divisor (dpb b-hlgh-di vidend 31. 1 0))) 

lit (Binus-f ixnum obU3) 

(goto ,(f intern "DIVIDE-vn-Q^" step)) 
(goto ,(f intern "DIVIDE-^-Qr step))))) 
CO 1 lect 

• (defucode ,(f intern "DIVIDE-'^D-SllB-l" steo) 

(parallel 

(assign b-high-di vidend 

fjf fm\Jt arnegative-divisor (dpb b-high-di vidend 31. 1 0) D) 
(If (minus-f fxnum obus) "^ ' 

(goto ,(f intern "DiVIDE-vO-Q8*' step)) 
collect ^°^° -{f intern "DrlVIDE-^-Qr step))))) 

'(defucode ,(f intern -DIVIDE--O-ADD-0" step) 
(parai I e I '^ 

(assign b-hich-di vidend 

(if (mmut-r^Snum'ibus') ''''°' ^^^^ b-high-di vidend 31. 1 0))) 
(goto ,<f intern *'DlVIDE.-^-a0- step)) 
collect ° ^t*i"tern -DIVIDE.-^-Qr step))))) 

'(defucode ,(f intern •DiVIDE--0-AOO-l- step) 
(paral t el ^ 

(assign b-hi nh-di vidend 

(if (minu^r^SSSl^obuif'^'^^' ^^P^ ^-^''3h"d'vidend 31. 1 0) 1)) 
(goto ,(f intern "DIVIDE-*O-Q0' step)) 
collect ^°^° .<^ intern "DIVIDE-O-Qr step))))) 

•(defucode ,(f intern "OIVIDE-vQ-QO" steo) 
••(if (« step 1) ^ 

' ( (para i lei 

(assign a-diyide-atep~count (1- a-divide-step-count)) 
(if (minus-f ixnua obus) wwui.w/ 

(sequent iaI 
;Remainder correction 
(assign b-high-di vidend 

(parallel'*' ^"^'S^'^'^'^^"":* a-posi t ive-divi sor)) 
(assign b- low-dividend 

. *?P^ b- low-dividend 31, 1 0)) 
(return) ) ) 
, , , , (drop- through))))) 

(paral lei 

(frubCs-31°"'^'''''^*"^ ^^^^ b- low-dividend 31. 1 0)) 
Tgoto ,(f intern "DIVIDE-vO-ADD-l" 
(gcto ,(f intern -ilv/DE-'^S^A^i-^i- '*"^* n-steps)» 

iif i> step 1) (1- step) n-fiteps)))))) 
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cot Icct 
Mdefucode ,(f intern "DIVIDE-^O-Dl" step) 
.•(if (■ step 1) 
'((paral Id 

(assign a-divide-step-count (1- a-divide-step-count) ) 
(if (minus-f ixnum obus) 
(parallel 

(assign b-tou-dtvidend 

(1+ (dpb b-tou-dividend 31. 1 8))) 
(return) ) 
(drop-through) ) ) ) ) 
(parai le! 

(assign b- lou-dlvidend (1+ (dpb b-tou-dtvidend 31. 1 0))) 
(i f ubus-31 

Tgoto ,(f intern "DIVIDE--D-SLtB-r 

(if (> step 1) (1- step) n-steps))) 
(goto .(f intern "DIVIDE— O-SUB-e** 

(if (> step 1) (1- step) n-steps))))))))) 

;For the simulator, nake it smalt and slow 
(divide-routine 2) 

;Thi9 does the first step and enters the toop at the appropriate point 
;The first step is different in that the dividend is not shifted beforehand. 
;The first step is also different in that if it produces a quotient bit of 1 
• ^*^«'*e is divide overflow (unsigned quotient doesn't fit in 32 bits). 
;rcr inteaer division, this only happens uhen the divisor is zero, 
•^'"^"'^C" dividing set2 by -1 (overflow to bignum) 
tdefucode divide-subroutine 
(parol )et 

(assign b-hioh-di vidend (+ a-negat i ve-di vi sor b-high-di vidend) ) 
lit Immus-f ixnum obus) 
(pcral iei 

(assign b- low-dividend (dpb b- tow-dividend 31. 1 C) ) 
(i f ubus-31 

(goto DIVIDE-2-ADD-1) ;2: see divide-routine macro above 

(goto DIVlDE-2-ADD-e))) ;.. 
(signal -error di v ide-by-rero) ) ) ) ; ? 

F:>lmach>ucode>d isle. lisp. 56 

;;; -«- flodeiLisp; Packaoerllicro; Base: 8; Lowercase: yes -»- 
;:: (c) Copyright 1932, Symbolics, Inc. 

;;; flicrocode for the disk 

:To do: 

; Save control tiemory by subrout ini zing more, including the nops 

; Add network to device service task 

(rese^ve-ccratchpad-memory 2518 251A 351 35G) 

:Do not use def ine-b-temp3 here, since this microprogram runs asynchronous lij 
;wiTh the emulator tssk 

;;; "Hardware" definitions 

;Xdev ice-service- task — low-priority task started at device-service- loop 

;ldi8k-daa-task — high-prior t ty tack started by service task when required 

(def ine-tbus-card iob> 

;;; Current state of the disk tasks 

;This register contains the physical address of the next word to be transferred 

:It can be looked at by macrocode (after a disk transfer) 

;The sign bit is 9 if this i s the last DAP. 1 if nore addresses follow (data chaining) 

(defareg Xdisk-memory-address) ^ 

(defatcaicro disk-merecry-address Sdisk-ceatory-address) ; synonym without the X 

;This register contains the number of words remaining to be transferred, minus 2 
;bef ore advancing to the next DAP. For the last DAP, this is the number of words 
;refflafnmg in the block, mmus 3 for a write or read-cor.pare, or 4 for a read. 
;Note: this register must be in the top 16 B registers to avoid having to 
;«ake disk-new-dop two cycles slower, which is undesirable since it runs 
;in a high-priority task. 
(defbreg-at-loc diik-word-count 37S) 

(defareg Xdisk-dcw-address) ;Phy3ical address of the first word in the 

;DCU command block currently being executed 

(defareg disk-dap-address) ;Address from which the next DAP wilt be fetched 

(defbreg current-disk-dew) :Copy of DCU currently being executed 

(defbreg current-di sk-dcu2) ;Second word of current DCU 

:For transfer commands, this is the desired sector header 
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(defareg Sdi sk-sector-max-tr tes (set-type 28. dtp-fix)) 

(defareg d i sk-eectop-tr ies) jCounts header compares to detect "search error** ^ maybe 

;due to disk heads being positioned wrong. 

(defareg Idi sk-ccmnand-address) ;Phy9ical address of disk command register 
(defareg Xd i -k-status-address) tPhysicai address of ^disk status register 

(defbreg di,sk-command-va 11) tFirst command to issue (search or transfer) 

t. xw _<• . ^ .-.. {Also used generally to hold disk status and as temporary 

idefbreg df sk-corrmand-valZ) : Second command to tssue (transfer: write or read-compare) 

Idefbreg d» sk-command-stop) ;Vaiue to store to stop it (no start bit) 

(defareg disk-temp) : Temporary for read-disk-status- to-vall 

(defareg Xdi sk-wakeup) ;Norm3l ly NIL, set to T by uakeup DCU, stop DCU, or error 

(defareg Xdi sk-micro-status) ;A fixnum which is the state of the microcode tasks 

,-Used both for intercomnunicat ion between the 2 »icro 
'♦tasks and for communication with the Lisp-coded driver 

(defatomic-bute-f ietd disk-micro-status (4 8) tdisk-micro-status) 
jasspciate-diGpatch-cues disk-micro-status «di sk-micro-status-codes«) 
idef ine-enumerated-value-constants »di sk-micro-status-codes*) 

(acscciatc-dispatch-cues Sldcw-aicro-command *dcw-«icro-comraands*) 

{2!*!**^-'®'''''"=*'*3'*'"^*^^«»*» ®^ iS'ts for each function required 

idefatomic-byte-f ield VXscrvice-di sk (1 0) service-task-requests) 

... p«^,,i^. ^ ^ jDHA task done; ready for next DCU 

fH*i - "®* service 

idetatoffl.c-byte-field Xtservice-net (1 1) service- task-requests) 

;• ' /receive end service 

••• AinorS;?^!^:^'**!^ XXservice-receive-end (1 2) servtce-task-rcquests) 

V;;*,; ^ transmit termination 

laetatom.c-byte-field XXservice-transmit-collision (1 3) ssrvice-task-requests) 

;Uakeup the disk driver uacrocode 

;Thi9 is called in the service task 

(defmicro wakeup-dr iver 

* (para) Id (assign Xdi sk-wakeup quote-t) 
(cal i oet-sequence-break) ) ) 

;UakeuD the disk service task 

;This is called in the DHA task usually, but can also be called by the emulator 

tdeftticro w3keup-di 5k-serv ice {) 

•(parallel (assign service-task-requcsts 

(logior f»rvice-t3sk-reque5ts (b-constant (byte-mask Xttservice-di ek) )) ) 
(wakeup-task Xdev t ca-osrv i ce-tssk) ) ) 

;92t the state of the disk DMA task. ^Hardware will wake i t up. 
(aefmicro start-di sk-dma (location) 
' (wr i te- task-state Xdi sk-dma-task 

(a-constant * (bui Id-tack-state cpc Jocation 

npc (npc-successor Jocation) 
csp 17)})) 

;0ts»is8 in both the CPU and the lOB, when not starting c dna cucle 
(defaicro d i sai ss-d r sk-task » j 

'(parallel (wr i te-(bus-dev iob 4 nil) 
(disaiss))) 

:5ame. with task-acknowledge (prevent overrrun) 
(defmicro di smi ss-di sk-task-and-ack (ficptional end-flaq) 
(parallel (wr i te-Ibus-dev iob ,( i f .end-flag S 2) nil) 
(disaiss))} 

;Space-5aver 

(defmicro phys-mem-read (address) 

•(parallel (start-memory read physical .address) 

(cal I phys-mem-read-detay) 

(dec i are-memory- timing (next data-cycte) 1 ) ) 

(defurcde phys-mem-read-delay 
(return) } 

;Terf«;nate the disk DHA task (called in that task). This is used for 

:botr! rsor^sal and error termination. Sets Xdi sk-micro-status to its 
;argu:^ent, awakens the service task, kills the disk dma task assignment, 
;and dismisses (looping a little until the di&mies takes effect). 
;lhis also clears control tag, while leaving the rest of the command 
;register, and the error status, intact. Ue must store into Xdisk-mtcro-status 
;betore awakening the service task, since we might enter this mtcrosequence 
;with a dismiss of the DHA task already pending: 
(defmicro terminate-disk-dma (di sk-status-code) 
• (sequent i a I 
(para I lei 

(extra-tjme-to-drive-lbus) tNeeded by many callers, save typing 

(assign *disk-micro-status (set-type .disk-status-code dtp-fix) ) ) 
xpBrB Mel 

(wakeuD-di sk-service) 

(jump terminate-disk-dma))) ) 
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(defucode terwinate-dtsk-dma 
iparal lei 
(dismiss) 

(uf i te-itus-dev icb 5 nil) 
(juwp tcrminate-di 8k-dmal ) ) 
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;Clear task assignment, control tag 
{Keep stabbing until the blood flous 



emp) 



;Save register while auaiting memory 
{Capture and synchronize memory data 
;Store resul t 



;The ICB is slow to drive the urite-data onto the bus 

;Put the extra time in the first ha)* so it occurs before the clock 

tWe uant the ecc bits to be set up at the memory before the clock (write command) 

(defmicro extra-t ime-to-dr ive-ibus () 

* (ffiicroinstructicn speed slow-first-half)} 

;If8 slow for microdevice reads, too, for the same reason 
(defatomicro rsad-disk-buf fer 
(para I (el 

(read-lbus-dev iob 0) 

(dec I are-speed clow-first-half))) 

;This kludge is to compensatft for the fact that the disk status register is not 
;Sar.chrcnired with the Lbus clock. There is no safe w5y to read a conai stent 
;£et of btts, however we can read whatever we get as long as no don't put it 
;in a place that has parity checking. 

;heEult ends up in the di sk-conmand-vol 1 B-regiater (low 28 bits only) 
(aefmicro read-disk-ctatus-to-vall 
(parallel 

(start-memory read physical tdisk-status-address) 
(cal I read-disk-status-to-vall))) 

(dcfucads read-disk-status-to-vall 
(paral lei 

J dec i are-meror y- 1 i m i no ac t i ve-cijc ! r ) 
(assign d»sk-temp trame-pointer) ) 
assign frame-romter memcry-data) 

^l^;??.?'!!*'"''''''^':^"''^'"^ frame-pointGr) 
*t^2^' 'ci ( assign frame-pointer disk-tern 

(return))) 
;;: Disk DIIA task. 

;This »icro generates the search for sector header at the frcnt of a DTIA routine 

{Entered the first ti»e with the disk idle, future times with the disk reading 

;5 cycles per wakeun if sector not found 

;1 cycle (plus body) when sector found 

(defBiScro def ine-di sk-eearch-ucode (tag Abody body) 

(or (eq (car body) 'goto) (setq bod;j Msequentiai . ,bodu))) 
' (defucode , tag 

;; Stop the disk state Machine if it is running 
(parallel 

(start-memory write physical *dt ck-command-addrecs) 
(assign memory-data di sk-command-stcp) ) 
;; Start the hardware searching for the next sector header 
(paral lei 

(start-memory write physical tdi riK-command-address) 
(ass ion menoru-data di sk-coar/and-volDJ 
;; Dismiss until the header has been read 
(parai lei 

(dismiss-disk-tack) 

:; Stop if too many tries without a header match 
(assign disk-sector-tries (1- disk-sector-tries)) 
(jf (minus-f ixnum obus) 

(terfflinate-disk-d»a Xdi sk-nicro-status-search-error) 
(nop) ) ) 
:; Come back here on next wakeup, with header in disk buffer register 
;; If header matches, drop through; otherwise keep searching 
(if (not-equal-f ixnua current-dJsk-dcwZ read-disk-buffer) 
(goto , tag) 
,body))) 




;thi$ uas not the last DAP. 

;Ue use up 6 cycles instead of the usual 2 per wakeup, 

(defucode disk-new-dap 

}"°P* . , ;Uart for nemory to be unbusu 

^paf"af'«l {Fetch first wcrd of DAP 

(start-memory read physical disk-dap-address) 

(assign disk-dap-address (1+ disk-dap-address))) 
Opal's' 'e' {Fetch seccnd word of DAP 

(start-memory read physical d t sk-dap-address) 

(assign disk-dap-address (1+ di sk-dap-addrcss) ) ) 
(paral Jel 

(dismiss-disk-task) 

(assign disk-word-count «>emory-data)) 
(parallel 

(assign disk-memcry-address memory-data) 

(return-skip (w tnus-f ixnum memory-data)))) {Test chain bit 
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;Read routine. Use this for both 32-bit and 3S-bit reads, 
(def ine-disK-search-ucode disk-read 
;; Uait for first data word in sector 
(d i OB I ss-d i sK- tasK-and-ack) 
( i f (minus-f t xnum di sk-memory-addreso) 
(goto disk-read- loop) 
(goto disk-read-loop-last))) 

;DnA transfer loop, when this is not the last DAP 
(defucode di sk-read-loop 
;: First cycle: increment RA, start memoru 
(parallel 

(start-memcry write physical drsk-mcmory-address dma iob 3) 

(assign disk-memory-address (1+ disk-memory-addresa) ) 

(disntiss) 

( i f Ibus-dev-cond 

(terwinate-di sk-d«a tdi sk-»tcro-status-disk-error) 
(drop-through) )) 
;; Second cycle: count down UC, 
(para I iel 

(extra- 1 ( me-to-dr i ve- 1 bus) 

(assign disk-word-count (1- diak-word-count) ) 
(if (mi nus-f ixnum obus) 
(para! le! 
;: First cycle for last word in this DAP. Transfer then fetch next DAP. 
;; Ue don t check for disk-error htre, but if there is one we* I I 
;; notice it soon enouah. 

(start-«iemory write physical disk-memory-address dma iob 1) 
(assign disk-wemory-address (1+ di sk-aernoru-address) ) 
(cal 1-and-return-skip disk-new-dap di sk-reid-toop-last dick-read-loop) ) 
(goto disk-read- loop)))) 

;DnA transfer loop, when this is the last DAP 
(defucode di sk-read-loop- last 

;; First cycle: increment HA, start Bemory 
(parai le! . 

(start-siemory write physical di sk-metnory-address dma iob 3) 

(assign di sk-memory-adoress (1+ disk-memory-address)) 

(dismiss) 

(if Ibus-dev-cond 

(term i na te-d i sk-dma Xd i sk-a i cro-sta tus-d i sk-error ) 
(drop-through) ) ) 
;; Second cycle: count down UC. 
(paral Iel 

(extra-t ime-to-dr i ve- Ibus) 

(assign disk-word-count (1- disk-word-count)) 
(if (minus-f i xnum obus) 
(goto disk-read-drain) 
(goto disk-read-loop-tast) ) ) ) 

;Here to read the last 3 words 
(defucode disk-read-drain 
;; Transfer last word with end flag, then 2 aore drain words which 
:: the disk sends before it stops 
(paral Iel 

(start-memcry write physical disk-meraory-address dma iob 7) 

(assign disk-memory-address (1+ disk-Bcmory-address) ) 

(d(smiss) 

(if Ibus-dev-cond 

( term i nate-d i sk-dma Xd i sk-mi cro-status-d i sk-error) 
(drop-throuoh) ) ) 
(parallel 

(extra- time-to-drive- Ibus) 
(ncp)) 
(paral iel 

(start-memory write physica/ disk-memory-address dma iob 7) 

(assign disk-mcfliory-address (1+ disk-memory-address)) 

(dismiss) 

( t f Ibus-dev-cond 

(terminate-di sk-dma Xdi sk-micro-status-di sk-error) 
(drop-through) )) 
(paral Iel 

(extra- 1 i «e-to-dr i ve- 1 bus) 
(nop)) 
(paral iel 

(start-memory write phusical disk-memory-address dma iob 7) 

(assign disk-memory-address (1+ disk-memory-address)) 

(dismiss) 

( i f Ibus-dev-cond 

( term t nate-d i sk-dma Xdi sk-m i cro-status-dr sk-error) 
(drop-through) ) ) 
(para! lei 

(extra- time-to-drive- Ibus) 
tncp) ) 

"iterminatS rt?«L "^=" «tate machine stops, after reading ECC 

I xerm I nate-d I sk-dma Xd t sk-mi cro-sta tus-end-read) ) 
:Ur I te routine. Use this for both 32-blt and 26-bit writes. 
;6 cycles the first time through 
(def 1 ne-d i sk-search-ucode d i sk-wr i te 

;: Stop the disk state machine 

(parallel 
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(8tart-«emopy urfte physical Idi sk-command-addpess) 

<assign ■cmory-data disK-com»and-stop) ) 
;; Suitch disk over to write operation, then feed first word without dismissing 
(parallel . ^ . 

(8tart-«emory write physical tdi sk-command-address) 

(assign memory-data di sk-cowinand-val2) 

(jump disK-wr f te-startup) ) ) 

;For first DMA transfer when writing, must not check state machine aliveness since 
;it hasn't sent us any wakcups yet. Must decide whether this is last (and first) DAP. 
(defucode di sk-wr i te*startup 
;; increment flA, start aemory to fetch first word of write data 
(para I iel 

(start-memory read physical disk-memory-address dma ioP 3) 

(assign disk-aenory-address (I'f disk-menory-address) ) 

(dismiss) 

(if (minus-f ixnum obus) 

(goto di sk-wr i te-loop-1) 

(goto disk-wr ite- loop- las t-1)}}} 

jDIIA transfer looo, not last DAP 
(defucode di sk-wr i te- loop 
;; First cycle: increment MA, start memory 
(parallel 

(start-memory read physical disK-memory-address dma rob 3) 

(assign disk-memory-address (1+ disk-memory-address)) 

(dismiss) 

(if Ibus-dev-cond 

( term i nate-d t sk-dma tdi sk-mi cro-status-d i sk-crror ) 
(goto disk-wri te-loop-1)))) 

(defucode di sk-urt te-loop-1 
;; Second cycle: count down UC. 
(para! Iel 

(assign disk-word-count (1- disk-word-count)) 
(if (minus-f ixnua ODus) 
(parai Iel 
;; Transfer last word and fetch new DAP 
(start-nemory read physical disk-memory-address dma iob 1) 
(assign disk-memory-address (1+ di sk-tnemory-address) ) 

(cal 1-and-return-skip disk-new-dap di sk-wr i te-loop-1 as t disk-wri te- loop) ) 
(goto disk-wr i te-loop) J ) ) 

;DHA transfer loop, last DAP 
(defucode di sk-wr i te-loop- last 
;; First cycle: increment MA, start memory 
(para I I.el 

(start-memory read physical disk-memory-address dma iob 3) 
(assign disk-memory-address (l-»> disk-memory-address)) 
(di smt ss) 
(if Ibus-dev-cond 

(term! nate-d i sk-dma X6i sk-mi cro-status-disk-error) 
(goto di sk-wr i te-ioop-iast-1) )) ) 

(defucode d i sk-wr i te- 1 oop- 1 ast-1 
;; Second cycle: count down UC* 
(paral lei 

(assign disk-word-count (1- di ek-word-count) ) 
(if (minus-f ixnum obus) 

(goto disk-ur i te-drain) 

(goto disk-wr i te-loop- last)) ) ) 

J Transfer last two words in sector with end flag 
(defucode di sk-wr i te-drain 

(parallel (start-memory read physical disk-memory-address dma iob 7) 
(assign disk-memory-address (1+ disk-memory-address)) 
(dismiss) 
(if Ibus-dev-cond 

{ term i nate-d i sk-dma Xd r sk-m i cro-status-d i sk-crror) 
(drop-through) ) ) 
(nop) 

(parallel (start-memory read physical disk-memory-address dma iob 7) 
(assign disk-memory-address (1+ disk-memory-address)) 
(dt smiss) 
(if Ibus-dcv-cond 

( term i nate-d i sk-dma tdi sk-mi cro-status-d i sk-error) 
(drop-through) )) 
(nop) 

;; wake up here when state machine has swallowed last word 

Idi smrss-di sk-task) 

(nop) 

:; wake up here when state machine ctops, after writing ECC 

t term i nate-d t sk-dm a Xdi sk-mi cro-status-e nd-ur i te) ) 

?flead-compare routine. Use this for both 3i2-btt and 35-bit reads. 
;This is a hybrid of read and write 
(def ine-disk-search-ucode di sk-rsad-compare 
;: Stop the disk state machine 
(paral iel 

(start-memory write physical Xdi sk-command-address) 
(assign memory-data disk-command-stop) ) 
;: Switch disk over to read/compare operation, then feed first word without dismisstno 
tpara I le I 
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(start-memory write physical Xdi sk-command-address} 
(assign wemory-data di sk-command-va 12) 
(jump disk-read-compare-startup) ) ) 

;For first DMA transfer, must not check state nachine aliveness since 
;tt hasn*t eent lis any uokeups yet. Hust decide whether this is last (and first) DAP. 
(defucode di sk-read-compa^e-star tup 
;; Increment HA, start memory to fetch first word of data 
(parat let 

(start-memory read phusicaf disk-memory-address dma iob 3) 

(assign disk-memory-address (1+ di sk-»emoru-address) ) 

(dismiss) 

(if (m Inus-f i xnum obus) 

(goto di Gk-read-compare-loop-1) 

(goto di sk-read-coffipare-ioop-last-1))}) 

;DnA transfer loop, not last DAP 
(defucode di sk-read-compare-loop 
;; First cycle: increment flA, start memory 
(parallel 

(start-«ieraory read phusical' d'^sk-menory-address daa iob 3) 
(assign di sk-meraory-address (1+ disk-aemoru-address) ) 
(dismi ss) 
(if Ibus-dev-cond 

(terminate-disk-dma Xdisk-micro-status-disk-errcr) 
(goto disk-read-compare-loop-1)))) 

(defucode disk-read-compare- I oop-1 
:; Second cycle: count down Ut, 
(parai iei 

(assign disk-word-count (1- disk-word-count)) 
(if (minus-f ixnum obus) 
(parai iei 
;; Transfer last word and fetch new DAP 

(start-memory read physical di sk-memory-address dma iob 1) 
(assign disk-memory-address (U disk-memory-address)) 
teal l-and-return-skip disk-neu-dap 

. . .. ^ ^ disk-read-compare- 1 OOP- last di tk-read-compare-loop) ) 

(goto disk-read-compare-loop) ) ) ) 

jDflA transfer locp, last DAP 
(defucode d i sk-read-compare- 1 oop- 1 ast 
;; First cycle: increment MA, start «emoru 
(parallel 

(start-memory read phusical disk-memory-address dma iob 3) 

(ass I an di sk-memory-aadress (1+ di sk-ftemory-address) ) 

(dismiss) 

(if Ibus-dev-cond 

(termlnate-disk-dma tdi sk-micro-status-disk-error) 
(goto d I -k-read- compare- I oop- I ast-1) ) ) ) 

(defucode d i sk-read-compare- 1 oop- 1 as t-1 
;; Second cycle: count down UC. 
(parai lei 

(assign disk-word-count (1- disk-word-count)) 
(if (minus-f ixnum obus) 

(goto disk-read-compare-drain) 

(goto d i sk-read-compare- i oop- 1 ast) ) ) ) 

;Transfer last two words in sector with end flag 
(defucode di sk-read-compare-drain 
(parai iei 

(start-memory read physical disk-memory-address dma iob 7) 

(assign disk-tiernory-acdress (1+ di sk-»emoru-address) ) 

Vdismiss) 

( i f Ibus-dev-cond 

(terninate-disk-dma Xdi sk-mi cro-status-di 8k-error) 
(drop- through)) ) 
(nop) 
(parai iei 

(start-memory read phusical d i sk-memory-address dma iob 7) 
J^^I^S'^^^'Sk-memory-audress (1+ di sk-«emory-address) ) 

(if Ibus-dev-cond 

!ir^Ii!'??*®*^'^^-^^3 tdtsk-micro-status-disk-error) 

(cl^op-through))) 
(nor) * 

'(d.sm'^sfl-disK^^task?'' '^^^* machine has swallowed last word 

iterr.m3te-S!Ek-dm^4H*^•' -"^chine steps, after reading ECC 
- °'^'' '^'"S^^i^isk-micro-status-end-read-compare)) 

(call-and-return-to start-read-op-ur i te-al I diek-wr i te-startup) ) 

'(SefS^oii "s"-'?ead-a?i' '"' '" '"'*'" ""'" *^«" ''^'' ■""^'"S- 

(calf start-read-or-wri te-al i) 

(disffiiss-dlsk-task) 

(if (minus-f ixnum disk-memory-address) 
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(goto disK-read*loop3 

(goto disk-read-! cop- last))) 

;£tnct index pulse is narrow^ ue actual ty loop in this high-priority tack 
(defucode start-read-or-uri te-al I 
;; Loop until Index is true 
.(re3d-disk-status-to-va!l) 

(if (field-bit disk-command-vall XXdsr-tndexJ 
(drop-through) 

(goto Rtart-read-or-wri te-al 1 )) 
:; Start up the disk state machine. Bg the tiae it gets going ue should 
;; be near the trailing edge of Index, 
(para tie I 

(star t-«emory ur ite physical Xdi sk-command-address) 

(assign nemoru-data disk-cQaimand-val2} 

(return)}) 

;Sector-uait command (used for eeek-uait) 

;Service task starts hardware in Sector Wait command. Ue uakeup ifenedlately 

;and then a^ain at the beginning of the next sector 

(defucode disk-sector-wait 

(dismi ss-di sk-taski 

(nop) 



;; Uake up here when state machine sees sector pulse 
( term i na te-d i sk-d«a td i sk-m i cro-s ta tus-end-sec tor -wa i 



t)) 



Read-header command 

Service task starts hardware in Read command, ue awaken iamed lately 
and then again when sector header found 

. — This is pretty much guaranteed to cause an overrun. •* what to do? 
(defucode dick-read-header 

(dismiss-disk-task) 

(nop) 

;; Do a Dr.A write of the header into the DCU list (in the inmediate arg of the read-header) 

(start-memory write physical disk-dap-address dma iob 1) 

(jtcrjinate-di sk-daa Sdi sk-m i cro-s tatus-end-wr i te) ) 
;;; Service task 
J for now, only serves the disk. Add the network later. 

(defucode device-service-ioop 
;; Scan requests for service 
(if (bit XXscrvice-di sk) 

;: Disk service (DHA task not running now) 
(di spatch-af ter-thi s disk-micrc-status 

(assign tiservice-disk (b-constnnt 2)) 
( (tdi sk-m icro-« tat us- idle Sdi sk-m i cro-s tat us- in-sec tor Xdi sk-m i cro-s tatus-s top) 

( jump dcv I ce-serv ice-end) ) ;Use jurp rather than goto to save space 
( (*disk-ffii cro-status-search-error Sdi sk-micro-status-disk-error 
Sdi sk-mi cro-status-ecc-done) 
(par a I I e I (uakeup-dr i ver ) 

(jump dev i ce-serv i cs-end) } ) 
( (Sdi sk-micro-status-start) 

(ooto fetch-disk-dew)) 
( (Sdi sk-m i cro-status-end-sector-wai t) 

(iump disk-seek-wai t)) ;Use jump rather than goto to save space 
( (Sd t sk-m i cro-status-end-wr i te) 

(cal i-and-return-to check-disk-status next-disk-dew)) 
( (Sd i sk-m i cro-status-end-read) 
(call check-disk-status) 
(para I tel 

(trap-if (not (field-bit di sk-coKmand-val 1 SSdsr-ecc-ok) ) di sk-error-detected) 
(jump next-disk-dew))) 
( (Sd I sk-m i cro-status-end-read-compare) 
(call check-di sk-etatus) 

(trap-if (field-bit di sk-cowmand-vall SSdsr-compare-error) disk-error-detected) 
(para I lei 

(trap-if (not (field-bit disk-co»»and-vall XSdsr-ecc-ok)) di sk-error-detected) 
(jump next-disk-dew))) 
(otherwise 
(goto device-service-end) ) i ; Ignore any garbage status 
;; No requests for service 
(goto net-scrvice-toop) ) ) 

:; I f no requests, dismiss. If aore requests have come in, go do them without 
;; dismissing. Check must be in tame cycle as dismiss to avoid hazard. 
(defucode device-service-end 
(paral i^ I 

(trar -i f (not-rero-f i xnum service- task-requests) 

device-service- loop) 
idismiss)) 
(nop) ;Uait two cycles for dismiss 

(jump device-service-loop)) 

;Read disk status register. Die if error, and return status in di sk-command-va U. 
;Note that the control stack can remain pushed spuriously if an error is detected. 
;Tnis is not a problem since there are no magic locations in this task's control stack. 
(defucode chcck-di sk-status 

(read-disk-status-to-vail) 

(parai tel 
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(trap-if ftiit-test (a-constant fget 'Xdsr-error-Kask 'sycconstant) ) disk-coamand-vall) 

di sk-error-detected) 
(return))) 



(assign Id i sk-m i cro-status (set-type Sdi sk-aicro-status-di sk-erpor dtp-fix)) 
(parai lei (uiakeiip-dr i ver) 



(defucode di sk-error-detected 
Ji sk-micro-£totus 
(uiakeiip-dr i ver) 
(jump device-service-end))) 

;; Do next DCU after the one ua just did 
(defucode next-disk-dew 
(parallel 

(assign Xdi sk-dcw-address (+ Xdisk-dcw-address (ldb-fie!d current-disk-dcu Wdcw-length) ) ) 

(junp fetch-disk-dcu) ) ) 

;; Oo DCU uhose address has been set up 
(defucode fetch-disk-dcu 

;; Start fetch of first word 

(parallel (start-nemory read physical tdisk-dcui-address) 

(assign disk-dap-address (1+ !i^di8k-dcw-address) ) ) 
;: Start fetch of second word 
(parallel (start-nemory read physical di sk-dap-address) 

(assign disk-dap-address (1+ disk-dap-addrecs) ) ) 
;; Store the DCQ away. Cannot be overlapped with dispatch due to damnable field conflicts 
(assign current-disk-dew mefnory-data) 
(assign current-disk-dcwZ fcemory-data) 
;: Decode the DCU 

(dispatch-af ter-this (Idb-field current-disk-dew XXdcw-micro-coMand) 
;; Initialize aicro status 

(assign %di sk-aii cro-status (set-type Xdt8k-«icro-status-in-sector dtp-fix)) 
((Xdcw-u-nop) 

(goto next-disk-dew)) 
({'>;dcw-u-8top) 
(sequent iai 

(assicn Xdisk-rricro-status (set-type Xdi sk-aicro-status-stop dtp-fix)) 
(para I lei (wakeup-dr iver J 

(ju»p dev ice-ser vice-end) J )} 
( (Xdew-u-wakeup) 
(para I lei (uakeup-dr i ver) 

(jump next-disk-dew))) 
( (Xdew-u-goto) 
(parai let 

(assign Xdisk-dcw-address current-disk-dcwZ) 
(jump fetch-disk-dew))) 
( (Xdcu-u-head) 

(aoto disk-head-select)) 
( (idcu-u-seek-wai t) 

(goto di£k-seek-wai ti) 
( (*dcu-u-read-header) 
(start-dtsk-dma di sk-read-header) 

(parallel (start-memory write physical Xdi sk-command-address) 
(assign memory-data eurrGnt-di8k-dcw2) 
(jump device-service-end))) 
( (Xdcw-u-read) 
(parai lei (start-disk-dma disk-read) 

(jump start-dtsk-transfer))) 
( (Xdcw-u-wr i te) 
(parallel (start-disk-dma disk-write) 
(jump start-disk-transfer))) 
( (Idew-u-read-compare) 
(parallel (start-disk-dma disk-read-compare) 
(jump start-disk-transfer))) 
((Xdcu-u-read-ai I ) 
(parai let (start-disk-dma disk-read-al I) 
(jump start-dtsk-transfer))) 
((Xdew-u-wr i te-al I ) 
(parai lei (start-disk-dma disk-uri te-al I) 
(lump start-disk-transfer))) 
( (tdcw-u-ecci 
(start-disk-dma disk-ecc? 

(parallel (start-memcry write physical Sdisk-command-address) 
(assign memory-data current-di 8k-dcw2) 
(jump device-service-end))) 
(otherwise ;Oie if garbage seen 

(sequential 

(assign Xdisk-micro-status (set-type Xdisk-micro-status-stop dtp-fix)) 
(paraT lei (wakeup-dr i ver) 

(jump device-Bcrvtce-end) ) ) ) } ) 

:Transfer DCUs come here. The state of the DHA task has been set, 

(defucoae start-di sk-transfer 

;; Start fetch of third word (command) 

•(parallel (start-memory read physical disk-dap-address) 

(assign di sk-dap-address (1+ disk-dap-address))) 
;: Start fetch of first DAP 
(parallel (start-memory read physical disk-dap-address) 

(assign disk-dap-address (1+ disk-dap-address))) 
; ; Stash command 

(assign disk-command-vaU memory-data) 
;; Cosiptete fetch cf first DAP 
(assiqn disk-word-count memoru-data) 
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Iparafiei (star i-memory read phijsicol di sk-dap-addresoJ 

(assign dick-dap-address (1+ disk-dap-address))) 
(assign di sk-cornmand-stop (logand di sk-command-vall 

(a-constant llognot (f ield-»ask XXdcr-busy) ) ) ) ) 
(assign disk-meiTiopy-addpess memory-data) 

;; Screw around for 2 extra cycles tecauss of conflicts for AnUA 
(assign dt sk-rector-tr ies (Ido-field current-di sk-dcu Xtidcw-dcr-command) ) 
(assign disk-sector-tries (dpb-field disk-sector-tries %%dcr-conimand di sk-command-val 1) ) 
(acsign disk-comfT;and-val2 d i sk-sectcr-tr ies) 
(assign diek-tector-tries Xdtsk-aector-iiax-trics) 
(parallel (start-ieaory write physical Xdi sk-comraand-address) 

(assign BeBiory-data di sk-comniand-stop) ;Uake up and go to sleep 

(jump dcvica-tervica-end)) ) 

; Check uhether teek has completed fWfnediateiy and at every sector pulse thereafter 
(defuccde disk-seek-uai t 

(parallel (assign Xdiek-micro-status (set-type Idisk-micro-status-tn-sector dtp-fix)) 

(cat I check-di sk-status) ) 
(if (field-bit disk-command- vail XSdsr-on-cyl tnder) 
(goto next-di sk-dcu) 
(drop-through)) 
(start-disk-dma disk-sector-uai t) 

(parallel (start-memory write physical Sdi sk-command-address) 
(assign iiemory-data current-di sk-dcu2) 
(jump device-service-endt) ) 

;Head select — need to twiddle tog bit up and dcwn 
idefucode disk-head-setect 

;; Write bus, with tag bit turned off 

(parallel (start-memory write physical Xdt sk-command-address) 

(assign memory-data current-di •k-dcu2) ) 
;; Urite again, with tao bit turned en 
(assign di sk-command-vall (togior (a-constant (field-mask IXdcr-head-tag) ) 

current-di sk-dcw2) ) 
(parallel (start-memory write physical Idisk-command-address) 

(ass ion memory-data di sk-command-vall) 

;; Delay a microsecond or so by checking for error status 

(call Check-disk-status)) 
:; Clear tag bit, leaving same value on bus 
(parallel (start-memory urite physical tdisk-command-address) 

(assign memory-data current-di sk-dcw2) 

(jump next-di&k-dcw) ) ) 

\Errcr correction computation. Ue have to do the word counting here. 

;Do it in Idisk-memoru-address so when we're done the macrocode can read it. 

;Ftrst, have to take 335-72 uakeups to recycle the ecc code (335 is the 

•ecc code field size of 423S7 divided by 128, 72 is the sector size 

;divided by 128). The state machine takes care of the extra bits for 

; the remainder of 423S7/128, minus the 32 bits already clocked when the 

;ecc was read at the end of the sector and the 64 bits already clocked 

;when the prefix was read. 

;The -4 is because if Xdisk-memory-address starts out negative the state 

; machine will still process 3 12S-bit chunks before it sees the end flag. 

idefucode disk-ecc 

(parallel (assign Id isk-memory-address (set-type (b-constant (-335. 72. 4)) dtp-fix)) 

(dismiss-disk-task) 

(jump disk-ecc-loop-1))) 

(defucode disk-ecc-loop-1 

(if (minus-f ixnum Xdi sk-memory-address) 

;; Finished recycling code, start counting words of data field 
;j Start at -3 because ue will wake up twice while two more 128-bit 
;; chunks are passed over, and if we stop after the first word, that 
;: is word 0. 

(parallel (assign Xdi sk-memory-address (set-type (b-constant -3) dtp-fix)) 
(d i cm I ss-d i sk- task-and-ack end- f I agJ 
(jump disk-ecc-toop-2) ) 
(drop- through)) 
:; Uakes up here 

(parallel (assign Xdi sk-memory-address (set-type (1- Xdi sk-memory-address) dtp-fix)) 
(di smi ss-di sk-task-and-ack) 
(jump dtsk-ecc-loop-D) ) 

;Now run and count words, until state machine stops or full sector size has been scanned, 
(defucode disk-ecc-toop-2 

(if (greater-or-equal-f ixnum Xdi sk-memory-address (b-constant 298.)) 

(terminate-di sk-dma Xdi sk-micro-status-ecc-done) ; Uncorrectable error 
(drop-througn) ) 
; ; Uakes up here 

(parallel (assign Xdi sk-memory-address (set-type (1+ Xdi sk-memory-address) dtp-fix)) 
(disml ss-di sk-task-and-ack) 

(if Ibus-dev-cond ;Uas this a complete word, or did st mach stop? 

(terniinate-di sk-dma Xdi sk-mi cro-status-ecc-done) :Correctable error 
(goto disk-ecc-loop-2) ) )) 

;;; Initialization — maybe some day the microcode loader can take care of this? 
;;; In the meantime the startup microcode should call this subroutine 

(defucode di sk-ini t iai ize 

(par a I let 

(ur i te-task-state Xdevice-service-task 
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;:; -»- PtodetLiap; Packagetfltcpo; Base:8; Louercaaetyes -»- 
;;; (c) Copyright I3&2, Symbolics, Inc. 

;;; tli-crocode for aaster control 

;Get defaicro and alt his hosts 

(declare (cond ((not (status feature Iwucode)) 
(load 'udcis)))} 

(def ine-sysconstant matn-stack-buf fer-address) 
(def ine-sysconstant auxi I iary-stack-buf fer-address) 

(reserve-8Cpatchpad-«e«iopy 251A 2520) 

(defareg current-dp-control ) ;Copy of dp-contpof registcp (can't read back) 

(defapcg a-page-faui t-address) ;VnA of last page fault (fop debugging) 
(defareg a-page-faul t-uicpo-pc) tMicpo-PC of last page fault (fop debugging) 

;If this peg i step is non-zero and ue pcisp, «ave-bi tbi t-buf fcp »ust be 
;called after pcstoping the stack pointep. 
(defareg bi tbI t-buf fcp-act ive 8) 

;Stapt the ■achine hepe 

(defucode-at-loc stapt 1 jlBS FOOBAR 

(assign b-quote-t quote-t) ;These ape needed on the B side 

(paral lei 

(assign b-quote-nil quote-nil) 

(cal I disk-initialize}) jinitialize other tasks 

?; Initialize virtual address nap 

(papal lei (assign vma (a-constant 0)) 
(cat I cleap-naD-cache) ) 

; ; Ini t iai ize flags 

(assign a-pclsp-top-of-stack (set-type (b-constant 8) dtp-nuH)J 

(assign bi tblt-buffer-active (b-constant 8)) 

(assign stack-load-stapted (b-constant 0)) 

(assign currcnt-dp-contpol (b-constant 0)) 

(assign a-stack-group-lock quote-nil) 

(assign b-c3chsd-niapping-tabie quots-ni!) 

(assign ^:stack-buf far-low (set-type (b-constant 0) dtp-fix)) ;do this in Bacrocode latep. 

(assign %5tack~buffep-l imi t (set-type (b-constant 8) dtp-fix)) 

(cal I sui tch-to-auxi l iapy-stack-buf fep) 

(parallel (pushval funct lon-system-stantup) ;CalI this function to start up 

(call funcal l-8-ignope)) ;Bui Id fpame headep, set PC 

;; nark this fpame as the bottom fpame so we tpap if it tries to retupn 
(papal le I 

(assign frame-* isc-data (logiop frame-mi sc-data ; Cause trap on return 

(b-constant (+ (byte-mask fra«e-buf fer-underf lou-bi t) 

fr^^it *,,-*•,.• ^^y T . . . Cbyte-mask fra«e-bottom-bit)))}) 

(ca nittalize-net)) ; Ini tial ize the network 

(paral lei 

(assign frame-previous- frame quote-nil) tNo back-pointer in this frame 
(jump pcIsp))) sAdjust CSP and take instruction dispatch 

;:; PcIsp 

;Come hepe with new PC (to escape to) loaded. Cleap the micpo stack, reset the 
;main stock, and return to the main loop (eventually the IrU dispatch address) 
(defucode pel sr-restcre-stack 

(cal J-and-return-to restore-stack-pointer pclsr)) 

(defucode pc I sr 
;; Pop stack until clear. If not in emulator task. halt. 

:: Don*t pep controt -stack simultaneous with test, it would cause SQ NEXT INST 
;; to come on spuriously M stack uas alpeady cleap. 
( i f (not-repo- f ixnum (pead-cur-task) ) 
;; Not in emulatop task 
(hal t pel sr-in-io-tack) 

;; In emulator task, check csp left in b-temp as bu-nroduct 
(if (equal-f ixnum (Idb b-tcmp 4 IG.) (a-constant 17)) 
;; Stack is empty, exit 

(parallel (assign a-pclsr-top-of-stack (set-tupe (a-constant 0) dtp-nul!)) 
(jump pclsr-done)) ;ttust make sure above flag is clear 
;; Stack not empty, pop and try again 
(parai tel 

(for -effect (pop-control -stack)) 
(jump pclsr) )) )) 

(defucode pclsr-done 

(if (not-zsro-f ixnum bi tb I t-buf fer-act i ve) 
(goto save-bi tbi t-buf far) 
(next- instruct ion) ) ) 

;Restope stack-pointcp to its value at the stapt of this macroinstpuction, 
;clobber!ng top-of-stack (but no tempopar i es ! ) 
(defucode restore-stack-pointer 

(assign too-of-stack (logior (a-constant -1_4) stack-adjustment)) 

(if (Tdb-bi t-test top-of-stack 3) 
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(assign stack-pointer (- stack-pointer top-of-stack) ) 
(assian stack-pointer (- stack-pointer (Idb tcp-of-stack 3 0)))) 
(if not (data-type? a-pcl cr-top-of-stack dtp-nuM)) 

_ (parallel (assign top-of-stack-a a-pclsp-top-of-stack) 
(return)) 
(return))) 

;;; Multiple stack-buffer primitives 

;Discard the state of the auxiliary stack buffer ar6 resume the saved state 

;of the main stack buffer. If Xsequence-break-pending is set, trap imnsdiately. 

(definst Xresume-wain-stack-buf fer no-operand 

(error- tf (not (equal -pointer Xcurrent-stack-buf fer euxi 1 lary-stack-buf f er-address) ) 

i I legal-instruct ion) 
(if (not-data-type? Xaequence-break-pending dtp-nil) 

(parallel (assign tsequcnce-break-pending quote-nil) 
V (cat t tet-sequence-break) ) 

(drop- through) ) 
(assign XcontroT-stack-low tother-control-stack-lou) 
(assign Xcontrol-stack-l imi t Xother-control -stack- M ni t) 
(assign ^Cbinding-stack-lou Xother-bindinci-stack-lou) 
(assign Sbinding-stack-l imi t Xother-binding-stack- 1 imi t) 
(assign Vb inding-stack-po inter Xother-bind ing-stack-pointcr) 
(assign Xcatch-block-l i st Xother-catch-block-l i st) 

(assign Xcurrent-stack-group-status-bi ts Xother-stack-group-status-bt ts) 
(assign pc tother-pc) ;No instruction fetch since page fcult must be deferred 
(assign frame-pointer tother-frame-pointer) 
(assign ttack-pointer Xother-stack-pointer) 
(par al lei 

(assign Xcurrent-stack-buf fer (set-type »arn-etack-buf fer-address dtp-fix)) 
(assign b-tcmp obus) 
(call set-stack-buffer)) 
(parai tel 

(assign top-of-stack top-of-stack-a) 
{jump set-stack-buffer-limit))) 

;Exp licit suitch to aux ab. 

jStack contains function, arga, count of args. All popped upon return, no values 
; returned unless they are pushed "by hand" before resuming. 
(definst Ifuncal l-in-auxi I iary-stack-buf fer (no-operand needs-stack) 
;; Perform context switch and pop our arguments 

(assiqn a-temp (- stack-pointer top-of-stack D) ;Addres3 of the function 
iparal iel 

(assign vma (Idb a-temp 13. 8 ^air-^i^tack-buf fcr-address) ) jTranstate to physical address 
idecrement-stack-po inter) 
(cal I swi tch-to-auxi I iary-stack -luf f^r) ) 
(parai lei 

(assign tother-stack-pointer (- Xoxher-stack-pointer top-of-stack 1)) 
i jump'Xfuncal l-in-auxi ) iary-stack-buf ferl) ) ) 

(defucode Xfuncal t-in-auxi I iary-stack-buf ferl 

;; CoDu function, args, count into neui stack, then perform a function call 
(parai lei 

(start-memory read block) 
(assign tcp-of-stack (1- top-of-stack))) 
(if (greater-f txnum top-of-stack (a-constant -2)) 
(sequential 
(parai lei 

(assign (amem (stack-pointer 1)) aemory-data) 
( incrcment-stack-pointer) ) 
(parat Iel 

(assign vma (Idb vma 18. 8 main-stack-buff er-addrcss) ) 
(lump Xfuncst i -in-auxi I iary-stack-buf ferl ) ) ) 
(parai lei 

(assign (amem (stack-pointer 1)) Bemory-data) 
( i ncrcmen t-s tack-po i nter ) 
(assign top-of-stack memory-data) 
(ca I I f unca I I -n- i gnore) ) ) 
;: Mark this frame as the bottom frame so ue trap tf it tries to return 
(assign frame-mi sc-data (logior frane-mtsc-data ;Cause trap on return 

(b-constant 1+ (byte-mask frame-buf fer-underf low-bi t) 
(byte-mack frame-bottom-bit) 
(byte-mask frame-trace-bit))))) 
(parai lei 

(assign frame-previous-frame quote-nil) 5N0 back-pointer in this frame 
(next- instruct ion) ) ) 

;Subroutine to save the main stack buffer's context and select the auxiliary buffer, 
rgiying it a freshly-created small control stack, and no binding stack 
;Thi3 control stack resides in virtual ophysicat space, 

(defucode sui tch-to-auxi I iary-stack-buf fer 
; ; State save 
(asElgn Xother-pc pc) 

(assign lother-frame-pointer frame-pointer) 
(assign *AOther-stack-pointer stack-pointer) 
(assign Xother-control-stack-lou Xcnntrol-stack-lou) 
(assign Xother-control-stack-l imi t Ttcontro I -stack- I imi t) 
(assign Xother-binding-stack-lou Xb I nding-stack- I ow) 
jassjgn Xother-binding-stack-1 imi t Xb inding-stack-l i mi t) 
[assign 40ther-bindina-stack-pointer tbinding-stack-pointer) 
lass.nn *other-catch-block-l ist Xcatch-b lock- 1 i St) 
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tassign lothep-8tack-group-8tatu9-bi t3 :icurpent-9tack-grcup-8tatus-bi tsJ 
; : Set up neu state 

Jassinn Vcontrol-atack-iou (set-type auxiliary-stack-buffer-address dtp-!ocat i ve) ) 
tassign ^ccntroi-stack-Mmit (set-type (+ Xcontrol-stack-toy (b-constant 1403)) 
(a = c r^r. *f*.-^^- dtp-locative)) 

ass.o^ Tr|!nd. ng-stack-iou (s-t-tyre (b-constant 8) dtp- I ocat i ve) ) 
iass.^n *D.n3.ng-stack-limit ^ibi nd i ng-stack- I ou) 
(assign !tbinding-8tack-po inter Xb tnding-ttack-low) 
(assign Xcatch-block-l i 8t quote-ni!) 
(assign ^current-stack-group-status-bt ts 

(set-type (a-constant (field-mask eg-hal t-on-error) ) dtp-fix)) 
(assign frame-pointer (set-type (b-constant 0) dtp-null)) ;[ guess.,. 
(assign stack-pointer (1- Xcontpol-stack- tew) ) 
(assiqn stack-limit Xcontro i-9tack- I imi t) 
(parallel 

(assign Xcurrent-stack-buf fer (set-type auxi 1 iary-stack-buf fcr-addresD dtp-fix)) 
(assign b-temp obusJ 
(jump set-stack-buf fer) ) > 

;Te!l the hardware to use the stack buffer whose address is in b-temp 
(defuccde set-stack-buf fer 
iparai lei 

(ur i te-dp-cortrol f I db b-terip 2 18. currcnt-dp-control ) ) 
(assign current-dp-control obus) 
(return)) ) _ . - -^ 



;;; Sequence Break 

:Set the sequence break flag in the hardware. This is usually called in an I/O task. 
(defucode set-scquence-break 
(parallel 

(uri te-dp-control (dpb (b-constant 1) 1 2 current-dp-control ) ) 

(assign current-dp-control obus) 

(return))) 

;5equence break is deferred if we are already in the auxiliary stack buffer. 
;Otheruise switch stack buffers and call the function SEQUEN*Ct-BREA)C with no args. 
jThere is guaranteed always to be enough extra room in the main stack buffer 
;to do the necessar^jj pushes for this. Ue don't use an escape function because 
; there are no pcJErmg issues, we want to store the real pc in Xother-pc» 
;and it would save at most one control -memory location. 
;Note that the hardware ensures that the EPC is not incremented past the 
; instruction that would have been executed next were it not for the sequence break. 
; in the TnCb the DPC gets incremented, however, 
(defucode-at-!oc sequence-break 16803 
;; Clear the flag in the hardware 
(para I tel 

(wri te-dp-control (dpb (b-constant 0) 1 2 current-dp-control) ) 
(assign current-dp-control obus)) 
;; Defer if already on aux buffer 

(if (equal-pointer Xcurrent-stack-buf fer auxiliary-stack-buffer-address) 
(parallel (assign Xsequence-break-pending quote-t) 

(dro -through?? ' ^U"««>Pty-t'^apJ ^ {Recycle fake IFU by loading PC 
;; Go call the sequence-break handler 
(iiach i ne-ver s i on-case 

((tmcS ifu) tFunction call wilt advance the return PC 

(assign pc (pc-plus-number pc (b-constant -1)})) ; so decrement it to cancel that cut 
lotherwt se ml)) 
(pushvai function-sequence-break) 
(paral lei 

(pushvai (set-type (a-constant 0) dtp-fix)) -No arguments 
^JMl?P.A*""^3l i-m-auxi I iery-stack-buf fer) )) 
;:; Page fault trap-out 

;Come here if there is a page fault, with the referencing address in VDA, 

;and the fault tyoe (Xpage-pht-mi ss or Xpaoe-wr i te-faul t) in a-temp. 

;Ue wilt do a " take-pre-trap restore-stsck" then call FACE-FAULT with two 

;arguments» on the auxilianj stack tjuffer, whether or not we were olresdij there. 

:The macrocode is in charge of figurinq our whether this was a "recursive" page fault- 

; There is guaranteed always to be enourh extra room in the main stack buffer 

: to do the necessary pushes for this, 

(defucode page-fault 

;; Save debuqrjing information. Storing micro-pc takes two ci'des because of 
;; Ar»JA conflict and also because vslfd NPC needed tor following call, 
(ass inn b-temp (locand (pop-control -strrk) (b-constant 37777))) 
(assign a-page-fauTt-oicro-pc (set-type b-temp dtp-fix)) 
(paral lei 

lass inn a-page-faul t-address vma) 

;; Restore sp to its state at the start of the instruction 

(call restore-stack-pointer) ) 
;; Push funcall block for entering the page-fault macrocode 
(pucnva 1 funct i on-page-f au 1 1) 
(pushvai (set-type vma dtp-fix)) 
(pusnval (set-type a-temp dto-fix)) 
(pushvai (set-type (a-constant 2) dtp-fix)) ;2 arcs 

;; i=iestore pc to its state at start of instruction (now that vaa is saved) 
(each i ne-ver s i on-case 

(tifu tn:c5) nit) ;Hardware takes care of it 
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((tmc) 

{if icqua I -pointer a-paoe-fauf t-micro-oc 

(tD-constant ' (Lui Iti-task-state cpc 1 f j-empty-trap-1 npc cap B) ) ) 
(drop-through) ;Ktudne: don't back up PC if fault on inst fetch 

" (assign pc tpc-plus-number pc (b-constant -1)))))) 
;; Call the function, switching to auxiliary stack buffer if not already there 
(cal !-seIect-and-return-to 

(equal -pointer Xcurrent-stack-buffer auxi I iary-stack-buf fer-address) 
funca! l-n-ignore tfuncai l-in-auxi I iary-stack-buf fer 

Dclsr)) „ 

;TemDoraru for debugging. If you see this, it isn't here, 
(definst ihack no-operand 
(nop) 
(nop) 
(nop) 
inext-instruct ion) ) 

F :> lmach>ucode>CATCH . LISP . 10 

;;; -*- node:Lisp: PackagetPlicro: Base:8: Lowercase: yes -*- 
;;; (c) Copyright 19S2, Symbolics, Inc. 

; Hicrocode for catch/ throw/unutnd-protect instructions 

;Get defoicro and alt his hcsts 

(declare (cond ((not (status feature Imucode)) 
(load •udcis)))) 

; Initialize Xc3tch-b lock- ! i st to nil (temporary kludge) 
; This is now done by > Im5ch>sysdf 1 
; (defareg ticatch-block- I i st *ntl*) 

; Temporaries 
(reserve-scratchpad-meracry 2^24 2432) 

(defareg a-catch-pc) 
(defareg a-catch-nwords) 

;PLJSHVAL without settina the top-of-stack register 
(dcfmicro pushvaJl (val) 

'{parallel (assign (ameni (stack-pointer 1)J (set-cdr ,val cdr-next)) 
( increment-stack-pointer) ) ) 

;This Bicro writes the code for the catch-block-creation instructions 
(defmicro catch-open (value-di spcsi I ion ^optional unwind-nrotect-hair) 
(setq value-disposition (f ind-posi t ion-in-l ist value-di spcs i t ion 

•(ignore stack return multiple))) 
•(sequential 

;; The tag is already in the stcck. Now push the PC, BSP, and thread, 
(if (not-zero- f ixnum ri3cro-unsrgned-i jrmsdiate) 

(pushvall (pc-add pc nacro-unsigned-immediate) ) 

;; Offset of rero means r-P offset off the stack, and push PC back on. 

,(if (not unwind-protect-f.air) 

'(neutcp (pc-add pc top-of-stack)) 

;; Harry c3£e for unw tnd-protect, twiddle the stack 
* (sequent ia I 
(paral Icl 

(assign b-temp next-on-stack) 
(assign next-on-stacK top-of-stack)) 
(neutcp (pc-add pc b-tsmp)))l) 
(pushva I lb 1 nd i ng-s t ack-po i n ter ) 

(puEhval-wi th-ccr (set-cdr *catch-biock- t i st .value-disposition)) 
;; Now link up to the list and set the flag bit in the frame 
(assign Xcatch-block-l i st 

(set-tiipe (- stack-nointrr (b-constant 3)) dtp-locative)) 
(parallel (as&Tgn frame-catch-bit (b-constant D) 
(ncx L- instruct ion) ) ) ) 

(definst catch-open- ignore (uns tgned-pc-re!at ive needs-stack) 
(catch-ooen ignore) T 

(definst cstch-cpen-stack (unsigned-pc-relat i ve needs-stack) 
(catcn-cpcn stack)) 

(definst catch-open-return (unsigned-pc-rclat ive needs-stack) 
(catch-open return)) 

(definst catch-open-multiple (unsigned-pc-relat ive needs-stack) 
(catch-open multiple)) 

;— This uses T as the magic tag meaning unwfnd-protect. This is temporary, 
(definst unwind-protect-open uns;gned-pc-re!at i ve 
(sequential (pushval quote-t) 

(catch-open ignore t))) 

;C losing off the current catch block. Ue are given a number of words at 
; the top of the stack to be preserved. Everything between them and the 
;base of the catch block is removed from tne stack, the binding stack 
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;tc unucunri if necesscpy, the biock re unthreaded, bits in the frama 

{header are cleared as necessaru. Now if the catch block uas an unuind-protect» 

;the Cleanup handler ts pushj'cd to; otherwise the inctruction simply rxturns. 

{definst catch-closs uns i gned- i mr.ed t ate-operand 

(psrcliel (ascinn a-catch-nwcrda nacro-unsigned-inirrediate) 
(Jurp catch-ciose-D) ) 

(definst catch-ciose-mjl tipiG no-operand 

Ipsrallel jcherK-arg-tupe top-of-otack top-of-stack-a dtp-fix) 
(acstgn o-catch-nuords (1-r top-of-stack-a) ) 
(jump catch-close-1))) 

'fnZfMr^Hl'^::!^'!'^! ^^^ *^f nuwccr of tjcrd3 to be preserved at the top of the stack 
lutivjcouc Cf5tcn-ciOEe-j, 

\lS^^^' ^r^ catch block addr^essb Ic. Assume it resides in the current frame, 
lasstgn^xbas Xcatch-biock-i ist) 

:: p" ': ""-t we shoiiid fcoi around with unsafe pointers to the stack 
fU^'^'' ^"^^^^tiindirg stack since that can pcisr 

(if mo^-equai-pointer b-terr.p Ibinding-stack-pointer) 
(cai I pop-bindincj-stack-to-b-temp) 

:restore Kbas? 
(drop-through)) 
;: Copy out the parts of the catch block that ue u\ n need 
(assign b-temp (amem (xbas 8))) ;Catch tag 

(if (equal-tuped-pomter b-temp quote-t) ;unwind-Drotect 
(sequential ^ 

(parat lei 

(?"i'«?=hf^?2;g-2))"" '""" ^''^ '"^'"""p "'"'^''^ ^'^'*^«" 

{S«?nn'n?'^i r=».h „.i tNow pushj to cleanup handler 

assign pc a-catch-pc) -Don't use set-pc. Ue must not pclsr 

n»,t m«t,.,,r+;«„n 'f"*^ ^'"^ ^2 = ' "" ^^^ "tch ever again. 

;Blt down the stack (cannot pcfsr after this point) 
(defucode catch-ciose-2 

Ifff'T S-*ernp frame-pointer) ;Save FP used as a temporary 

ass.gn b-temp-2, stack-pointer) -Last word to save ^^^^^^ 

assign frame-pomter . b-temp-2 a-catch-nwords) ) ;First word to save-1 
(plra??e? *'°"'^^^ Xcatch-block-Mst)) -F/ush stack down to base of block 

!r!?i-s.^''^ir:?!°^*'"^''®^ ^^'"^'^ ^""^^^ 2**^ :Unthread this catch block 
icai 1 b i t-stack) ) 

{paral tel 

(assign frame-pointer b-temp) ;Restore FP 

(if (data-type? Icatch-block-l ist dtp- locat i ve) 

(if (greater-or-equal-pointer Xcatch-block-l i st b-temp) 

(Srop-^hrough)) '^*'" ^'^"'^ ^^*=^ ^'°^*^' '" *^'» ^'"atne 

(drop-through) )) 
(parat lei 

(return) )V"*'^^^^^"'''* ^^^-^onstant B)) ;No more blocks this frame, clear bit 

F:>1mach>ucode> 

; -»- Mode: Lisp; Base: 8; Lowercase: yes -«- 

; Bogus Hi crocode for testing that various things are possible 
; Not all of this will work m the simulator p ^s o e 

:Get defmicro and all his hosts 
(declare (cond ((not (status feature Imucode)) 
(load 'udcis)))) 

;nicro for the first cycle of a trap handler. 
;Finishes the state save bu calling for a PUSHJ, which eaves 
;the original CPC (new in HPC) onto the stack. The original NPC 
;is already on the stack. ^ 

(defmicro trap-save U 

• (nicroinstruct ion control-stack puchj)) 

;nicro for the last two cycles of a trap handler. 

;Takes arguments of what else to do in those cycles, that 

;seeming clearer than throwina a parallel around the sequence. 

•t^?/?^-"':'' mH? ^9 ^1"^ ^^'^ ^^^ ^y ^"'« popping the control 
:stack into NrC. I" the second cycle we also use NPC as 
;as the source for* CPC, Thus the push order is NPC, CPC and 
;the pop order is CPC, HPC, 
(defmicro trap-restore (cycle-1 cycle-2) 
* (sequent iai 
(paral tel 
, eye I e-1 

(microinstruction control -stack popj npc ctos)) 
ipar a t I e I 
,cycIe-2 
(njtcroinstruction contro ! -stack popj npc ctos cpc npc)))) 
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; Invisible-pointer traps 

;If transporting was needed, rt has happened alreadg 
J Time- 2 cucles trapping + 3 cycles here 
(defuc.ode Inviz-trap 
(para! let 

(trap-save) 

(assign vira meirory-data) 

(assign b-trans-vna memory-data)) 
(trap-restore 

(Kemoru-map read) ;Gurkh! Sometines needed to write here????? < 

(nop))) 

;nap-miss trap 

;Hardu:3re started memory reference to first level hash table in trapped 
;cycle: so the data are available in the first cycle of the trap handler, 
; since trapping inserted an extra clock uhtch drove the memory pipeline, 
;This is too early since ue aren't ready for it that fast. 
;Time • 2 cycles trapping + 4 cycles here in most favorable case. 
jlt's 4 cycles rather than 3 because Abus is a bottleneck (VttA, flD) . 
(defucode map-mi ss-trap 
(para! lei 
(trap-save) 

(assign b-map-temp (Idb vma IB, 8))) ;Uith address epace ID? 
(para I lei 

(increment-pma) 

(if (eaual-f txnum memory-data b-map-temp) ;natch pht key? 

(trap-restore (ur i te-map-from memory-data) :Yes, and VPIA still set up 

(map-metering)) ;Spare cycle for metering 

xKxxxx))) 'tWell, go off end search second level 

:DisK Oru task. 



:The follcuiny control registers are set up by the background 
;serv(ce task, based on the command list in main memory set up 
;by Lisp code. At the same time the hardware control r-rgictcrs 
;are (all?) set up. The background service task also bashes the 
;DnA task state to start it up at the right place for read or write. 
;Uhen the DHA task is done, tt wakes up the backoround tack which 
;can tell what happened by looking at the control registers. 



(defareg a-disk-ma 3^00) lAddress of next word to transfer 
(defareg a-disk-wc 308n ;Number of words to transfer (minus 3) 
(defareg a-disk-header 3032) ;Heaaer value being sought 
(defareg a-disk-t imeout 3303) jNumber of header tries before punting 

; (maybe heads are positioned wrong) 

(defareg a-di sk-search-cmd 3084);Ten hardware to search for header 

;Search subroutine. Returns after reading the header of the desired sector. 
:Eats shit and dies if header not found after timeout (does not return), 
(defucode disk-search 

(assign b-temp (io-bus-data disk-data)) ; Read Lbus directly into DP?? 

,,,'.,. ; Or use extended B memory?? 

(if (equal-f ixnum a-disk-header b-temp) 

(return) ;HeadGr found. Let caller dismiss, 

(drop-through)) 
(para! !e! 
(disr-^t 5s) 

(assign (io-bus-data disk-control) a-disk-«earch-caid) ) ;Tru again 
(para I lei 

(assign a-disk-t imeout (1- a-di sk-t imeout) ) 

(if alu-carry -Not uet counted to -1 

(goto disk-search) ;Uake up back at disk-search 
(eat-shi t-and-die) )) ) ;0n next wakeup, actually 

;Read routine. Initially entered via gratuitous wakeup. Call search 
jrouttne which will return with disk entering data area. 
;nost uakeups are only for 2 cycles, except at the start of the wrong 
;aector we remain active for 4 cycles, and at the start of the right 
jsector we remain active for 5 cycles. These could each be decreased 
;by 1 as noted above, and could ba decreased more I guess by having 
{separate search routines for read and write. 
(defucode disk-read 

JdisaisE) ;Until start of sector 

(cal I disk-search) 

(dismiss) 

(jump disk-read- loop)) 

;Here for each data word 
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(defucode di sk-read- loop 
iparai le! 

(assign pma a-disk-fna) 
Icsa-read disk) 

(assian a-disk-raa (1+ a-disK-ma)) 
(dtsml ss) ) 
(parat le I 

(aisicn a-disk-uc (1- a-disk-uc)) 
(if alu-carry ;Not yet counted to -1 

(goto disk-read-loop) :Uake up back there 
igoto disk-read- tast-3)))) 

;Here for the third to last data word 
(defucode di sk-read- I ast-S 
(para I iel 

(assign pma a-disk-r.a) 
(dma-read disk) 

(assign a-disk-ma (1+ a-disk-ma)) 

(ic-bus-stop-signal) ; Te I 1 disk to etop reading after next word 
(disaiss)) 
(nop) 

^Ps^^'!*^' ;SuiaHcw last data word 

asstgn pra a-disk-ma) 

(dcia-read disk) 

(a£E(9n a-disk-ma (U a-disk-ma)) 

(df smi ss) ) 
(ncp) 

»"®.«**^?-!-w*-.^^^ ^^^^ 3"^ ^he state machine has stopped 

hacks, 
hardware 
' 'u usi-iae wnat to do. 

(paral Iel 

(awaken- task background-ser vice- task) 
(dismiss)) 

. (nop I 

;Kernel of biting from main itenory tc TV 

:This involves no rotation or alu ft:nction, just straight copy 

;used e.g. to update a screen image. 

;TV epoch corresponds to S microcode cucies in this version 
;lf a TV epoch can correspond to £ cycles (i.o. we use alt fast 
; »icroinstruct ions) things are oucn cSGJer, 



(defucode tv-ccpy-kernel 

(parallel (assign pma a-tv-pina) ;Us«»s Abus 

(assign memory-data b-templ) ;Uce3 B,X,0 busses 

( increment-pmci.- 1 
(parallel (assign Wumory-data b-temp2) ;Store 2nd word in TV 

(memory-map reed)) ;Start next Memory read 

arsign a-tv-pma i+ a-tv-pma (b-constont 2))) ;rtemory active, inc pma 
(parallel asstgn b-templ «emory-data) ;Stash first word froa mem 

(increment-pma) ) 
(parallel (assign b-templ memory-data) tUseo A, X busses 

( mcrement-pma) ) ) 

:Hcre we have to be able to increment the VMA by 2 

;riust happen entirely in the flC because there is no 

;cucle with abus free to ucs DP adder to increment it. 

;It rncrement-pma carries into the page bits of the Vf1A, 

; this will work. 

: There is some confusion about increment-pma here. Generally it 

;is assumed to increment pma and vma both. But since ue are 
■Jeavrng the read aooress in VMA, and switching PMA back and forth 
;between a direct load from Abus and mapping from VHA, ifs clear 
:that this mcrement-pma really should split in several different 
? memory-control funct ions. 

;Cycle Address Bus Data Bus 

;I TV address Ur i te data 1 

;2 Hemory Address Write data 2 — address bus conflict? — 

; 3 n ) 1 nil 

;A rieraory Address+1 Read data 1 

;5 ni I Read data 2 

;In cycle 2 the address bus wants to be the memoru address eo that 

; the read can get started, it also wants to be the TV address+1 

;for writing into the TV (except the TV doesn't actually need to 

;look at this anyway). 

;Also Memory Address+1 needs to come out in cycle 3, not 4, 

; since the memory is interleaved rather than page-mode, 

;;; -»- HoderLisp; Packaoetrii cro; EaserS; Lowercaseiues -ir- 

;;; (c) Copyright 1382, Symbolics, Inc. 

; nicrocode for branch instructions 
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;Get befmicro and all hi« hosts 

m 

(declare (cond ((not (status feature ImucodeH 
(load 'udcls)))) 

; These are branches the compiler knows about initially 

(definst branch si gned-pc-re I at i ve 

(set-pc (pc-add pc macro-signed-immediate) ) ) 

;This gets an offset from memory. Uould it be better to get a PC? 
(definst long-branch constant-pc-relat t ve 

(assign v«3 (- frame-function macro-unsicned-immediate D) 
(start-memory read) 
(assign b-temp pc) 

(parallel (checK-data-type memory-data dtp-fix) 
(mach i ne-ver s I on-case 
((tmc tmc5) 
(sequential (assign a-tenp memory-data) 

(set-pc (pc-add b-temp a- temp)))) 
(otherwise (set-pc (pc-sdd b-temp memory-data)))))) 

(definst branch-false s t gned-pc-re I at ive 
(if (data-type? top-of-stack-a dtv-ni !) 

(set-pc (pc-add pc macro-stcned-imraediate) 

(for-effect (popvalh) 
(parallel 

(for-effect (popval)) 
(next- 1 nstruct i on) ) ) ) 

(definst branch-true si aned-pc-re I at ive 

(if (not (data-type? top-of-stacK-a dtp-nil)) 
(set-pc (pc-add dc macro-sioned-innediate) 

(for-effect (popvalj)) 
(para I lei 

Ifor-ef feet (popval)) 
(next- instruct ion) ))) 

(definst branch-false-else-pop staned-pc-relat i ve 
(if (data-type? top-of-stack-a dtp-nil) 
, (goto branch) 
(para! iel 

(for-effect (popval)) 
(nex t- instruct ion) )) ) 

(definst branch-true-el se-pop s i gned-pc-re I at I ve 
(if (not (data-tupe? tcp-of-stack-a dtp-nil)) 
(goto branch) 
(para I iel 

(for-effect (popvat)) 
(next-instruction) ) ) ) 

(definst branch-fa I se-and-pop signed-pc-reiat ive 
(if (data-type? top-of-st2ck-a dtp-nil) 

(set-pc (pc-add pc macro-signed- immediate) 

(for-effect (popval))) 
(next-instruction))) 

(definst branch-true-and-pop staned-pc-relat ive 
(tf (not (data-type? tcp-of-stack-a dtp-nil)) 
(set-pc (pc-add pc macro-s ioned-immediate) 

(for-effect (popvalJ)) 
(next- i nstruct i on) )) 

;Thi8 is a random selection of other branches 

(comment ;The compiler doesn't uant to use these yet 

sNote: can't test zero simultaneous with popval due to xbus conflict 
;Okay since instruction has to take tuo cycles even if it doesn't branch 
(definst branch-zerop (svgned-pc-relat i ve'needs-stack) 
(paral Iel 

(check-f i xnum-larg-b top-of-stack 

(otherwise (signal -error unitrplemErnted-ari thaetfc) ) ) ; 

(if (zero-fixnum top-of-stack) 

(set-pc (pc-add pc macro-signed- immediate) 

(for-effect (popval))) 
(paral Iel 

(for-effect (popval)) 
(next-ins truct ion)} ) ) ) 

(definst branch-not-zerop (signed-pc-reiative needs-stack) 
(paral Iel 

(check-f t xnum-larg-b top-of-stack 

(otherwise (signal-error unimplemented-ar i thmet ic) ) ) j 

(if (not-zero-f ixnuffl top-of-stack) 

(set-pc (pc-add pc macro-signed- immediate) 

(for-effect (popval))) 
(paral Iel 

(for-effect (popval)) 
(next- instruct ion) ) )) ) 
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(definst branch-greater-op-equal (signed-pc-reiati ve needs-stack) 

(parallel 

(check-f ixnum-2arg9 aexf-on-stack top-of-etack 

(otherwise (signal-error uniwpleniented-ar i thaet i c) ) ) ; 

(decrement -stack-pointer) 

(if (greater-or-equa!-f ixnusi next-on-atack top-of-stack) 
(set-pc (pc-add pc macro-signed-iRmediatel 

(for-ef f set (popval J ) i 
(para I iel 

(for-effect (popvai)} 
(next-instruct ion)M)) 

(definst branch-eq tsigned-pc-relat ive needs-stack) 
(paral le! 

(decrement-stack-pointer) 

(if (equal-typed-pointer next-on-stack top-of-stack) 
(set-pc tDc-add pc macro-signed-iBmediate) 

(tor-effect (popvai D) 
(paral Iel 

(for-effect (popva!)) 
(next-instruct ion) ))) ) 

(definst branch-not-eq (signed-pc-relat ive needs-stack) 
(paral Iel 

(decrement-stack-pointer) 

(if (not-equal -typed-pointer ncxt-on-ctack top-of-stack) 
(set-pc (pc-add pc macro-sicjned- immediate) 

(for-effect (popvalF)) 
(paral Iel 

(for-effect (popvai)) 
(next-instruct ion) ) ) ) ) 

) ;end comment 

F:>lmach>ucode>bitbU-b1ocic-mode.1isp.l 

; -«- Mode: Lisp; Package: M i cro; Base: 8; Louepca8e!ues -«- 
;;;; BITBLT microcode for 3SC0 



(defmicro wai t ing-for-»emory ;document3t ion only, I guess. 

* (nop) ) 

(defmicro abus-arrau-data (£body body) 
Mparal iel 

(check-data-type wemory-data dtp-fix) ;thi8 traps forwarding pointers, right? 
^•body) ) 

(defmicro assign-vma-of fset (which irest stuff) 
(selectq which 

(S '(assign vma (+ bb-s-roi.'-addr bb-s-offset .astuff))) 
(D * (assign vma (+ bb-d-data-addr bb-d-offset ,«stuff))) 
(otherwi ee 
(terror {) •aseign-v»a-of fset knows about only S and D, not *^s" which)))) 

(defnicro paral le I -w i th-s-access (offset 4bodu body) 

(rake-meaory-access 'bb-s-row-addr 'bb-s-offset offset body)) 
(defmicro parallel-wi th-d-access (offset fibody body) 

(■ake-«emory-access *bb-d-data-addr 'Db-d-offset offset body)) 

(eval-when (eval compi le load) 

(defun ■ake-memory-access (baseaddr offset-syw offset body) 
(if (or (eq offset offset-sym) 

(equal offset '(1+ ,of fset-sym) ) ) 

(ferror "-^s is not a recognized offset for -vs" offset offset-sum)) 
(let* ((body (reverse body)) 

(finally * (abus-array-data , (car body)))) 
(do ((11 (reverse 

*((assign vma ,((f (atom offset) 

• (+ .baseaddr .offset) 
*(+ .baseaddr .(second offset) 1))) 
(start-memory read) 
(wai t ing-for-ciemoru) ) ) 
(cdr ID) ^ 

(body (cdr body) (cdr body) ) 
(I)) 
((and (nul I t I) (nul I body)) 
•(sequential .•! .finally)) 
(ccnd ((null II) (push (car bodu) I)) 
((null body) (purh (car iT) I)) 
(T (push Mparalle! .(car II) .(car body)) I)))))) 
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} ;eva!-when 

;; hair these up appropriately 

(defmi'cro 32- (operand) 

M- (b-constant 32.) , operand)) 
idefniicro 31- (operand) 

•(- (b-constant 31.) , operand)) 

(defmicro di spatch-af ter-thi s (operand this Abody clauses) 
• (sequent iai 

(dispatch-after-next , operand 

.•clauses) 
(para I iei 

(take-dispatch) 
.this))) 



(defmicro di spatch-af ter-oen (di spatching-on var-and-indices-and-bod Arest clauses) 
(let* ((var-and-indiccs" (first var-2nd-indices-and-bod) ) 
(bod (second var-and-indices-and-bod) ) 
(var (first var-and-indices) ) 
(indices (restl var-cr.d- indi cec) ) ) 
• (dispatch-after-next ,di spatching-on 
,«(loop for index in indices 

collect M(, index) , (prcgv (list var) (list index) (cval bod)))) 
.•clauses)) ) 

(defmicro i ncr-d-of f set 

'(assign bb-d-cffset (1+ bb-d-of f set) ) ) 
(defmicro decr-d-of fset 

•(assign bb-d-offset (1- bb-d-of fset) )) 

(defoicro incr-wrap-«-of f set (> 
* (sequent iat 

(assign bb-s-offset (1+ bb-s-of f set)) 

(if (greater-or-equal-f ixnum bb-s-of feet bb-s-row- length) 
(para I lei 

(lisp (format T *'-*^>>>UrapDirn ground on bb-s-cffset from *d." 

(low32 (tr ^bfc-b-offsetl))) 
(assign bb-s-offset (b-constant B))) 
(drop- through) ) ) ) 

(defmicro decr-wrap-s-of f set 
*ipara\ lei 

(assign bb-s-offset (1- bb-s-offset)) 
(if (minus-f ixnum obus) 
(paral tel 

(lisp (cerror T ''»>Decr wrapping around on bb-s-offset")) 
(assign bb-s-offset (1- bb-s-row-(ength) ) ) 
(drop-through) ) ) ) 

(defmicro store-word (datum) 

* (store-contents (set-type .datum dtp-fix) T) ) 



(defmicro paral le!-wj th-return (&body stm) 

•(,(if (eq «raachine-verslon« 'sim) 'sequential 'parallel) 

.•stm 
(return) ) ) 

;;This is incompatible with modularity 

(defmacro reserve-bi tbi t-scratchpad-memory (a-start b-start &rest stuff) 
(loop with a-ioc ■ a-start and b-loc • b-start 
for (name side) in stuff 
when (eq side 'a) 

collect * (defareg-at-loc .name ,a-loc 8) into forms 
and do (incf a- toe) 
when (eq side 'b) 

collect • (defbreg-at-Ioc .name , b-loc 0) into forms 
and do (incf b-loc) 
final ly (return 

* (progn *compi le 

Ireserve-Ecratchpad-memory , a-start ,(1- a-loc) 

.b-start , (1- b-loc)) 
.•forms) ) ) ) 

(defvar *fp-of fset-names« ()) 

(defmacro def-fp-of f sets (&rest names) 
(loop for i upfroffl 8 
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,]))) 



for name f n names 

append M (defatomicro ^name (amem (frame-pointer 
(remprop ' , name * def areg-at- toe) 
(renprop ^name 'defbrea-at-loc) 
(defprop ,name ,i fp-offset) 
(or (memq ',name «fp-off set-names*) 
(push ',name »fp-of f set-naaes«) ) ) 
into foo 
finally (return * (progn * compile ,«foo)))) 

;; decode fp offset numbers into symbols. Debugging only, 
(defun dtp (finest numbers) 
(loop for number in numbers 

collect (loop for name in «fp-of fset-names* 

when (equal (get name 'fp-offset) number) 

return name 

finally (return number)))) 



-fp-of f sets 

i-arg-alu bo-arg-width bb-arg-height 

i-arg-from-array bb-arg-from-x bb-arg-from- 

t-arg-to-array bb-arg-to-x bb-arg-to-y 

i-width-a 



; ( isp arg 

-y ; I i sp arg 
' ; I isp arg 
•ucode arg 
:ucode arg 
;ucode arg 
; ucode arg 
; ucode arg 
; ucode arg 
; ucode arg 
•ucode arg 
; ucode arg 
; ucode arg 
; ucode arg 



copied froQ arg on A side 



temp 
temp 
temp 
temp 
temp 
temp 



(def-fp-of f sets 
bb-- 
bb 

bb ^ ^, _ 
bb-width-a 
bb-s-data-addr 
bb-s-rou-of fset 
bb-s-of fset-a 
bb-s-bi tpos 
bb-s-row- length 
bb-d-data-addr 
bb-d-of fset-a 
bo-d-bi tpos 
bb-fcvent-count 
bb-alu-operat ion 

;;; Some temporaries, 

(reserve-bi tbi t-scratchpad-memory 2G53 372 

(bb-uidth b) 

(bb-s-offset b) 

(bb-d-offset b) 

(bb-constant b) 

(bb-s-word b) 

(a-temp-3 a) 

(bb-constant-a a) 

(bb- ident i ty a) 

(bb-s-uord2 a) 

(bb- s^rou-addr a) 

} . . __ _ _ __ ___ _^ _._._... 

(defmicro read-bb-e-word 

* (paral lei 

(assign a-temp (+ bb-width bb-s-bi tpos) ) 
(ca I I read-bb-9-uordl ) ) ) 

Assumptions about setup: 
bb-ccnstant has; 

>> for constant operations (9,-1): the constcnt; 

» for operations dependent only on source or destination (x, •'X, y, •^) ; 

a 3 for x,y or -1 for *'X,«vy; 
>> for operations dependent or. both s and d: for those using source directly, 
and -1 for those that want the source complemented, 

(defucode read-bb-s-uordl 
(assign-v«a-of f set s) 
iparatlel 

(assign byte-r (32- bb-s-bi tpos) ) 
(start-memory read)) 
(parai iel 

(uai t ing-f or -memory) 

(if ( lesser-or-equal-f ixnum a-teffp (b-constant 32.)) 
;; source is entirely uithin one word 
(paral let-wi th-return 
(abus-array-data 

(assign bb-s-uord (logxor bb-constant (rotate »emory-data byte-r))))) 
;; source rs split across two words 
(sequent iai 

tabuE-ar ray-data 

(assign bb-s-word (rotate «emory-data byte-r))) 
(assign-vma-of f set s 1) 
(parsTle! 



(start-memory read) 



tbyte-r is already ok 



(paral let 

(wai t ing-for-memory) 

(assign bijte-s (1- a-temp))) 
(abus-array-data 

(assign bb-s-word (dpb memory-data byte-s byte-r bb-s-word))) 
(paral lel-wi th-return 

(assign tb-s-word (logxor bb-s-word bb-constant-a))))))) 
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)) 



)) (assign bb-conc.tant-a (a-constant -1)) 



)) 



(defucode bb-copu-stuf f-to-b-aide 
(assign b-ter:p't)b-5-Pow-of fset) 
(assign bb-s-rou-addr (+ bb-s-dat3-ai';Jr b-temp)) 
(assjan bb-s-offset bb-s-of f set-a) 
(poral le! 

(assign bb-d-offset bb-d-of f set-a) 

(return))) 

(defmacro defucode-bi tbi t (name source destination neither both) 
* (defucode .name 

(paraMet (assign bb-uidth bb-uidth-a) 

(cal t bb-copy-stuff-to-b-side) ) 
(dispatch-af ter-this (Tdb bb-a?u-c:rer3t ion 4 9) 

(paraiiel (assign tb-constant (a-constant 9)) lassunption, for the 
(assign bb-constant-a (a-constant 9))) ;conimon case 
( (c) \o 

(goto ,nei ther)) 
((1) :x*y 

(parallel (assign bb- identity (a-constant - 
(jump ,both?)) 
((2) :^,c*y 

(ass inn bb- identity (a-constant -I)) 
(papal lei (assign bb-constant (a-constant -! 
(jump ,Ooth5)> 
((3) (pcturn)) ;y 

((4) ;;*^y 

(parallel (assign bb-i dent i ty (a-constant 
(jump ,both))) 
((5) (goto .soupce)) ;x 
((G) ;x xop y 

(parallel (assign bb-i dent ity (a-constant 9: 
(jump ,both))) 
((7) :x+y 

(parallel (assign bb-identity (a-constant 9 
(jump ,both) )) 
((8. ) ;*'K»^'j 

(assign bb-identity (a-constanx -1)) 
(papal lei (assign bb-constant (a-constant - 
(jur*p ,bcth))) 
( (3. ) • A^x xor u 

(assign bb-identity (a-constanl 8J) 
(parallel (assign bb-constant (a-constant -: 
(jump ,both))) 

((le.) ;-x 

(parallel (assign bb-constant (a-constant - 
(jump , source))) 
((11.) j-vx+y 

(ascian bb-identity (a-constant 81) 
(papal lei (assign bb-constant (a-constant - 
(jump ,both))j 

((12.) ;>vy 

(parallel (assign bb-constant (a-constant - 
(jump ,dest inat ion) ) ) 
((13>) ;x+'vy actually, -vC^.x^y) 

(assian bb-identity (a-constant -D) 
(papaT)el (assign bb-constant (a-constant -: 
(jump .both))) 
^y^'} t-N-x+'^y actually. •'(x»y) 

(papal lei (assign bb-identity (a-constant 
(jump .both))) 

((15.) ;-l 

(papa! lei (assign bb-constant (a-constant 
(jump ,nei thep)))) )) 

(defucode-bi tbit ubi tbI t-shcpt-row 

ubi tbI t-shopt-rou-source 

ubi tbI t-shopt-pou-desti nation 

ubi tb! t-EhoPt-row-nei thep 

ub! tbl t-chopt-rou-both) 
(defucode-bi tbi t ubi tbI t-long-row 

ubi tbI t- 1 ong-rot.4- source 

ubi tbI t-long-row-dest inaticn 

ubi tbI t-long-row-nei ther 

ubi tb I t- long-row-both) 
(defucode-bi tbI t ubi tbl t- long-row-backwards 

ubi tbI t-long-row-source-bacKwards 

ubi tb! t-long-row-dest inat i on 

ubi tbI t-long-rcw-nei ther 

ub I tb I t- I ong-row-both-backwards) 



(assign bb-constant-a (a-constant -1)) 

(assign bb-constant-a (a-constant -1)) 
(assign bb-constant-a (a-constant -1) ) 

(assign bb-constant-a (a-constant -D) 
(assign bb-constant-a (a-constant -1)) 

(assign bb-constant-a (a-constant -1)) 
(assign bb-constant-a (a-constant -1)} 



; direct ion immaterial 



idlJn!*'v!*:^°i:!l? eventually be folded back into defucode-bi tb 1 1 
idetinst *bi tbI t-shcpt-row no-opepand 
(jump ubi tbI t-shopt-pow) ) 

(definct ::&! tbf t-long-row no-opepand 
(jump uoi tbI t-lonQ-rcw)) 

(definst tbitb!t-long-row-backwardo no-operand 
t ju-p ubi tbi t- icng-row-backwards) ) 

l'3:-ftnst Ibi tt'M-decoris-apraus no-operand- 
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( ju»p ub i tb I t-decode-arrags) ) 

(de f ucode ub i tb I t-shor t-row-source 

(read-bb-5-word) 

(ass i on a-temp (+ bb-uidth bb-d-bi tpos) ) 
(if (lesser-op-equal-f ixnua a-tcmp ii3-ccnstant 32.)) 
; ;dest inat ion ts entirely uithin one word 
(para i i e I -u i th-d-access 
bb-d-offset 

(assign byte-s (1- bb-width)) 
(assign t>yte-r bt»-d-tDi tpos) 
(paraT i e ! -wi th-return 

(store-word (dpb bb-s-word byte-s byte-p neniory-data) ) ) ) 
; ;de5t mat ion is split across two words 
(sequent iai 

s; store the low byte 
(para t I e I -w 1 th-d-access 
bb-d-offset 

(assign byte-s 131- bb-d-b i tpos) ) 
(assign byte-r bb-d-bitpos) 

(store-word (dpb bb-s-word byte-s byte-r »enory-data) ) ) 
;;store the high byte, using ItiD into Bd as background 
(para I lel-wi th-d-access 
(1+ bb-d-offset) 
(assign bute-s (1- a-temp)) 
(assign byte-r bb-d-bitpos) 
; : byte-r i s oK 
(paral iel-wi th-return 
j*»J°J«-«0Pd (Idb bb-s-word byte-s byte-r nemory-data) ) 

(def ucode ubi tbi t-short-row-dest inat ion 
(ass I on a-temp {+ bb-width bb-d-bitpos)) 
(if (lesser -or-equal-fixnum a-temp (b-constant 32.)) 
;;destinatton is entireig within one word 
(sequential 

(paral lel-wi th-d-access 
bb-d-offset 

(assign byte-s (1- bb-width)) 
(assign byte-r bb-d-bitpos) 
(assign a-temp-2 memory-data)) 

IfS^l?? ?"^?T5 ^^P^ bb-constant byte-s byte-r (a-constant 0))) 
Iparai lel-wi th-return 

(store-word (loqxor b-tenp a-teffp-2) ) ) ) 
;;dest inat ion is split across two words 
(sequent iaI 

; ;munge the low byte 
(paral I e ! -w i th-d-access 
bb-d-offset 

(assign byte-s (31- bb-d-bitpos)) 
(assign byte-r bb-d-bitpos) 
(assign a-temp-2 memory-data)) 
(assign b-temp (dpb bb-.constant byte-s byte-r (a-constant 0))) 
(store-word (logxor b-temp a-terp-2)) 
; cmunge the hiqn byte 
(paral I e ! -w i th-d-access 
(1-t- bo-d-offsetJ 
(assign byte-s (1- a-temp)) 
assign byte-r (a-constant 0)) 
(assign a-temp-2 memory-data)) 
(assign b-temp (Idb bb-constant bytc-s bgte-r)) 
(paral lel-wi th-return « '' 

(st ore-word (logxor b-temp a-tcmp-2) ) ) ) )J _ 

;:the atu operation is actually a constant 
(defucode ub i tbi t-shor t-row-neither 

(assign a-temp U bb-width bb-d-bitpos)) 
(parallel ^ 

(if (lesser-or-equal-fixnum a-temp (b-constant 32.)) 
:;destinat ion is cntireiy within one word 
(paral lel-wi th-d-access 
bb-d-offset 

(assign tyte-s (1- bb-width)) 
(assign byte-r bo-d-bitpos) 
(paral lei 

IretCrnm"^ ^^^^ bb-constant hyte-o byte-r nisrr.cry-data) ) 

;t destination is split across two words 
(sequent iaI 

; tstore the tow bute 
(paral lel-wi th-d-access 
bb-d-offset 

(assign byte-s (31- bb-d-bitpos)) 
(assign byte-r bb-d-bitpos) 

:;i?ore'thrhi=h%.^r°"'''"' "«*'-» "^^^"^ "e«ory-data) ) ) 
(paral fe!-wi th-d-access 

(1+ bb-d-offsst) 

(assign byte-s (1- a-temp)) 
asston tyte~r (b-constant 0) ) 

(parai le( 

(re?Crnn))))f '^ bb-constant byte-s byte-r .emory-data) ) 
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;;the alu operation depends upon toth source and destination bits 
(defucode ud i tDI t-short-rou-both 
(reaa-bc-s-uord) 

(assign a-temp (+ bb-width bb-d-bi tpos)) 
(assian-vrr,a-of f set d) 

(if (Tesser-cr-equal-f txnum a-tenp (b-constant 32.)) 
;;dest inat ion ia entirely within one word 
(sequent ia i 

(assign byte-s (1- bb-uidth)) 
(parai lei 

(assign byte-r bb-d-bitpos) 

( iufr.p'bb-bute-a i u-operat i on-d i spatch) ) ) ; jca I I 
:;dest mat ion is split across two words 
(sequent iai 
;;store the low byte 
(assian byte-5 (31- bb-d-bi tpcs) ) 
(paral lei 

(assign byte-r bb-d-bitpos) 
(call bb-byte-at u-operat ion-dispatch)) 
;; store the high byte 

(assign bb-s-word (rotate bb-s-word bute-r)) 
(assign bute-s (1- a-tcnip)) 
(assign-vma-offset d 1) 
iparai lei 

(assign byte-r (b-constant 8)) 

(ju;?! P bb-byte-a) u-op erat ion-dispatch) ) ) ) ) ; jcall 

(boole fn X y ...) if fn is "*bcd""~Thcn ~" ~ 

W012345g7 

S, 3, ^ , 10 11 12 13 14 15 

* ( x+y ) * ( x^y ) *,x -rx+y ^y K+-y *x+-wy . 1 



e 

X 

1 



b d 



;vma and byte reg? have been set up already, for DPB. 
,:trashes b-temp, 3-temp-2. b-temp-2, but not a-temp. 
(defucode bb-byte-alu-operat ion-di spatch 

(dispatch-after-this JPsralieJ (star t-mewory read) ( Idb bb-alu-opcrat ion A 0) ) 

, ^ ^'wlft?ng-;or!«er^^^^ ""^'^'^ ^^^^"^ db-ident i ty) ) 

((1 2) ;;1 K*y logand ;;2 '*x«y logand 

(paral lel-wi th-return 
(parat le! 

(decl3re-memory-t tRiIng data-cycle) 
(abus-array-data 
ttL fi , ^s^P^e-w-^c*, ^togand memory-data b-temp)))))) 
(paral lei ^ "^ " *'*^^ ^"""^^^ ''^ "^^-^y* " ^"^^^ ^"=^^b 

(dec I are-memory- 1 i m i ng data-cyc I e) 
(abus-array-data 

(assign a-temp-2 memory-data))) 
(assign b-tenp-2 (dpb (b-constant -1) byte-s byte-r 0)) -can't mmmm fhi. 
assign a-ten,p-2 (iogxor a-temp-2 b.temp-2)) ^ •? with t^is 

(parallei-ui th-return k --^ / . . . .wi in ini s. 

/rc*2^?'"*"r°'"2 ^\^93nd a-ternp-2 b-temp)))} 
( b 3. ;;b >eA(y Iogxor ;;9 ^ Lxtf^j) m^xMu lOQXor 
(paral! e I -wi th-return y ^y "f 

(paral tel 

(dec I ar e-memory-t i m i ng data-cyc i e) 
tabus-array-data 
ff7 11 ^Store-word (Iogxor b-temp memory-data)))))) 

(paral let-wi th-return 
(paral lei 

(declare-menory-tiffling data-cycle) 
(abus-array-data 
ui-? ii®f°'"'^7o^^^ (logior b-temp memory-data)))))) 
(paral lil • '***^ " -(-»e*y) lognand ..14 -.x+-^«^(x*u) 

(dec tare-memory- timing data-cycle) 
(abus-array-data 

(pari??|i?Ci?h!re?:^n^'°^'"' ""^""^ «n,ory-data) ) ) ) 

(otni;Silr<g^t='?In?:hi^g^n))r?°"'^'"*_-^' ''"*""„''^-^ '' a.t.n,p-2)))) 
;;vma has been set up already 

(defucode bb-word-aiu-operat lon-di spatch ;common!u 3 cucles (n\n^ 1 *nr^ tK. ^^.f 
(d.spatch-after-this (paral lei (start-memory r«d) Od^ bb-^iu!ope?it!on 4 8) ' 
(d 2) ..1 x«u"?nn^nr °'"""'*"'°^^^ 7 ;— «ant to use this somehow... 
(parafle! logand ;;2*x«y logand 

(dec I are-memory-timing data-cue !e) 

(return) h'"'"^^^^ (store-word T I ogand bb-s-word memory-data))) 

*{parailel ''^ ''*"^ ^"'^'^^ ''^ "^'"''^^ **^*^y ^"'^'=^^ 

(deciare-memory-t iffiing data-cue I e) 
(P'etSrnnf^''^^^^ (store-word \a.^dc2 bb-s-word memory-data))) 
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((B 9.) ;;S x;?y fcgxor ;;9 *.(xtfy)-<vx/^y I onxor 

(para) tel ^ ^ ^ 

(dec I are-memopy- 1 i m i ng data-cue 'el 

(abus-array-data (store-word (iogxor bb-s-uord neraopy-data) } ) 

(petupn))) 
((7 11.) :;7 x+y logicr ;;11 -i.x+y I eg t op 

(papal !c! 

(dec lare-memopy-t iming data-cycle) 

(abu9-apray-data (store-wopd (iogiop bb-9-uopd memopy-data) ) ) 

(petupn))) 
((13. 14.) ;;13 K+*.y • *('^x»y) ;;14 *x+MJ.*. {x»u) 

(papal lei » - 

(dec lape-memopy-t iming data-cud e) 

(abus-appay-data (assign a-tefr.p-2 (logand bb-s-uopd wemopy-data))) ) 
Iparai lel 

(store-wopd (fogxop (b-constant -1) a-temp-2)) 
(petupn))) 

(ot_her_ui sc_(gqto cant-happen) U ) ^ 

;;aiu depends only on soupce bits 
(def ucode ub i tb 1 1- 1 ong-pou-soupce 
(paP3i iel 

(assign b-temp bb-d-bt tpos) 
(if (repo-fixnum bb-d-bitpos) 

iif (zepo-fixnum bb-s-bitposl 
(papal (el 

(??Ep^7tpace"?at"^/i}l ^'='-*-°^^"^* ^ ;bb-ai igned-row-soupce will incpcment fipst 
(jump ubi tbi t-al inned-pow-soupce) ) 
; ; SSSSSSSSSSSSSS5SS5SSSSSSS9SSSS5S 

; ; dddddddddddddddadddddddddddddddd 
(papal lel-ui th-s-access 
bb-s-offset 

(assign byte-p (32- bb-s-bi tpos) ) 
(parallel 

(assign bb-s-wopd (Ioqxcp bb-constant (rotate nemopy-data byte-r))) 
(lisp (tpace-path U/c)) 
(iump ubi tbi t-d-al igned-pow-soupce) ) )) 
(if (equal -f ixnum b-temo bb-s-hitpos) 

: ; SSSSSSSS55S5SSS33SSSSSS5S9SSSS9S 
; ;ODDDDDODDODDDDDDDGDDDDDDOddddddd 
(sequential 

(para I 1 e I -u i th-»-access 
bb-s-offset 

(assign a-temp (32- bb-d-bitpos)) 
(assign byte-p a-tesip) 

(assign bo-s-uord (logxop bb-constant (rotate ■emoru-data bute-r)))) 
(papal lel-Mi th-d-access 
bb-d-of f set 

(assign byte-r bb-d-bitpos) 
(assign byte-s (1- a-tenp}) 

(store-uord (dpb bb-s-word byte-a byte-r ■emoru-data) ) ) 
( mcp-d-offsetJ 
(papal lel 

(assign bb-width (- bb-uidth a-temp)) 
(I isp (tpace-path n/h)) 
(jump ubi tbI t-al igned-pow-source) ) ) 
(lessep-f ixnum bb-s-bi tpos b-temp) 

; ; sssssssss£SS5S3S3S£S^GS5S 

; : DDDDDDDDDDDDDDDOdddddddddddddddd 

; ; *- 32-d.bi tpos — * 

(sequential 

(papal lel-ui th-9-access 
bb-s-offset 

(assign byte-r (32- bb-s-bi tpos) ) 
(paraTlel 

(assign b-temp (32- bb-d-bitpos)) 
(assign a-ter.p cbus) ) 
(assign bb-s-wopd (iogxop bb-constant (rotate nemopy-data byte-p)))) 

! ; ssss5ss9sSS5bbSSSSS££SSSS 

(papal lel-ui th-d-access 
bb-d-of fset 

(assign byte-r bb-d-bitpos) 
(assign byte-s (1- b-temp)) 

(stope-wopd (dpb bb-s-uopd byte-s byte-r memory-data))) 
(incp-d-of fset) 

'•c?lc-?r|;^2u^Jy'*^^<*^ *o r^'Q^t by 32-d.bi tpos 

; ;b:3bbcibbbbba300J3 BS898SSSS 

(assign byte-r bb-d-bitpos) ;or left by -(32-d.bi tpos) 
(assign bb-s-uord (potate bb-s-uord byte-r)} 
(assiqn bb-width (- bb-width a-temp)) 
(parallel 

(assign bb-s-bi tpoc (+ bb-s-bi tpos b-temp)) 
(I tsp (trace-path U/d)) 
( Jump ub i tb I t-d-a I i gned-row-source) ) ) 
(sequent ial 
::1?L*''a^ P3^* °^ the first source word is not as long as the high part of the 
V:VJJI dest.nat.on wopd. £o extract the useful papt 5f the first sburce word! 
,, and deposit into it as much of the second source word as needed to fill out the rest 



(if 
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11 , . •••; DDDDDDDDDDDDDDDo'iDDDDfebSddr'""^ 

{paral le!-u) th-a-acces3 

bb-s-offsc-t 

(assign byte-p (32- bb-s-bi tpos) ) 

(assign b-temp bb-s-bi tpos) 

(assign bb-s-uorri ( logxor bb-constant (rotate nemoru-dota bute-r)))) 

•• * 5-d ► •-- 32-s — » (32-d)-(32-s)«s-ri 

:; 85ssfssssss3sscsSSSS£SSS£SS5SSS5illinilllK.. 

• ' CDDDOCDDDDDDODDD DDDDDDDDDOdddddd 

iparal !el-ui th-s-access 
bb-s-offsct 

{assign bijte-r (Z2- bb-s-bi tpos) ) 
assign byte-s (- b-temp bb-d-bitpos D) 
^assign bb-s-word2 (logxor bb-ccnstant memcpy-data) ) ) 
d sign bb-s-uord (drr-b bb-o-word2 byte-s bute-r bb-s-word) ) 
^«*-Stgn bb-s-bi tDDS (- h-t^mn hh-ri-wl ♦r-.no^ T 
:;aiu depends only on source bits 
(defucodc ubi tb I t-fong-rou-source 
(para) le! 

(assign b-terap bb-d-bitpos) 
(if (zero-f ixnuw bb-d-bitpos) 

(if (zero-fixnua bb-s-bttpcs) 
(parallel 

(assign bb-s-offset(l- bb-s-offset)} ;bb-al igned-rou-source wt H increment first 
(lisp (trace-path ^/a) ) 
( jump ub i tb I t-a I i oned-rou-sourre) ) 
: ; SSSS£SSS5S5SSS5£SSS£SSSSSsssssss 

; ; dddddddddddddddddddddddddddddddd 
(paral lel-ui th-s-access 
bb-s-of fset 

(assign byte-r (32- bb-s-bi tpos)) 
(parai lei 

(assign bb-s-uord (loqxor bb-constant (rotate •emory-data byte-r))) 
(lisp (trace-path tf/cl ) 
(lump ubi tbi t-d-aJ igned-POM-source) ) ) ) 
(if (equai-f ixnum b-temp bb-s-hitpos) 

; ; S5£S££S53S£££SS£S£££5SSSSsssscss 
; sODDDOOOOOODDDDOOOXOODDOOddddddd 
(sequential 

(paral lel-wi th-s-access 
bb-s-offset 

(assign a-temp (32- bb-d-bitpos)) 
(assign byte-r a-tesp> 

(assign bb-s-word (logxor bb-constant (rotate ■emory-data byte-r)))) 
(paral lel-ui th-d-access 
bb-d-offset 

(assign byte-r bb-d-bitpos) 
(assign byte-s (1- a-tenp)) 

(8tor«-uord (dpb bb-s-word byte-t byte-r meaiory-data) ) ) 
(incr-d-of fset) 
(p3pa! iel 

(assign bb-uidth (- bb-width a-temp)) 
(I isp (trace-path #/b) ) 
(jump ubi ttl t-al igned-rou-source) ) ) 
(if ( iesser-f ixnum bb-s-bi tpos b-temp) 

; ; sssssssssSS£SS3S5SS£Eb535 

: ; DDDDDDDDDDDDDODDdddddddddddddddd 

;; •" 32-d,bi tpos — * 

(sequential 

(paral lel-ui th-s-access 
bb-8-of fset 

(assign byte-r (32- bb-s-bi tpos) )• 
(parallel 

(assign b-temp (32- bb-d-bt tpos) ) 
(assign a-temp obus)) 
(assign bb-s-uord (loqxor bb-constant (rotate memory-data byte-r)))) 

; ; ssssssss5£SSbS££££3£££££S 

(paral lei-ui th-d-access 
bb-d-offset 

(assign byte-r bb-d-bitpos) 
(assign byte-s (1- b-temp)) 

(store-uord (dpb bb-s-word byte-s byte-r memory-data))) 
(incr-d-offset) 
;; rotate s-word further to right by 32-d. bi tpos 

; ; 5SS5SS£SS£SS££S£ sssssssss 

(assign byte-r bb-d-bitpos) ;or left by - (32-d. bi tpos) 
(assign bb-s-uord (rotate bb-s-uord byte-r)) 
(assign bb-width (- bb-wtdth »-temp)) 
(paral tel 

(assign bb-s-bi tpos (-♦• bb-s-bi tpos b-temp)) 
(i isp (trace-path tf/6)) 
( Jump ub \ tb 1 t-d-a I i gned-rou-source) ) ) 
(sequential 
;The hinh part of the first source uord is not ts long as the high part of the 
;tipst aestination uord. £o extpact the useful papt of the first source word, 
;and deposit into it as much of the second source uord as needed to fill out the rest 
;ot the first destination uord. Then position the rest of the second source word 
;apprcpr lately for the inner loop. 
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;: ^- 32-s -^ 

• ; • |SSS5SS5SSSa9S3SSS5S8a9«S899SS9S5 

; : DDDDODDODDDDDDDD DDDDDDODDDdddddd 

(para I te!-ut th-8-acces3 
. bb-s-offsGt 

lass inn t)yte-p (32- bb-s-bi tpos) ) 

(assign b-temp bb-s-bitpos) 

(assign bb-s-uord (logxor bb-constant (rotate •emory-data bute-r)))} 
I incr-urap-s-of f set) 

;; *- 9-d -* <-- 32-s — ► (32-d)- (32-9) -9-d 

:; 9999f99999S3S9cs5S5S£SSSSSSSS55Si 111 n 11111 

;; DDDDDCDDDDDDODDD DDDDDDDDDOdddddd 

(parai ie!-wi th-9-access 

bb-s-of f set 

(assign bijte-p (C2- bb-9-bi tpcs) ) 

(assign Lyte-5 (- b-temp bb-d-bitpos 1)) 

(assign bb-9-uoPd2 (tooxop bb-ccnstant memcpy-data) ) ) 
!:!'5'^ bi:-3-woPd (cipb bb-c-uopd2 byte-s byte-p bb-s-uopd) ) 
la.sign bb-s-bitpos (- b-temp bb-d-bitpos)! 
(399 ign a-temp (32- bb-d-bi tpo9) ) 
(a99ian bb-width (- bb-width a-tcmp)) 
(papal lel-wi th-d-acccss 

bb-d-of fget 

(assign byte-p bb-d-bitpos) 

(assign byte-9 (1- s-tef^p)) 

(incp^d-offget)"^^^ bb-c-uopd byte-s byte-p memopy-data) ) ) 

(assign byte-p (32- bb-s-bi tpo9) ) 
iparaiiei 

(assign bb-s-uord fpotata bb-9-uopd2 byte-p)) 

(j uirp ubf tbit -d-ai ic!ned-Po»-9oupcg) } } ) ) ) )± 



(def ucode ub i tb I t-a t i gned-pou-soupce 

(if (gpeatcp-op-equal-f ixnum bb-width (a-constant (« 8. 22.))) 

;;Fetch a bloc*^ of wopds onto the block of atnen past top of etack, and move sp thepe. 
(sequential 

(assign b-temp (+ bb-9-offset (a-conatant 8.))) 
(if (gpeatep-op-equ3l -f ixnum b-tcr;p bb-9-Pou- length) 
(goto ubi tbi t-at igned-pou-eoupce-sjow-loop) 
(sequent iat 

(assign-vma-of f set » 1) 
(para I le I 

(assign a-temp (b-constant S.)) 
(assign b-temp obus) 

(stsrt-memopy block pcad) ) ;9tapt fipst word 

(papal lei 

(uai ting-fop-memory) ;waitir,g for fipst word 

(stapt-Riemopy block pead) ;8tapt second uopd 

(ca /I ub t tb I t-b I ock-pead-push-8) ) 
(papal lei 

(assign-vma-of fset d) 
(cal 1 ubi tb! t-biock-wpi te-pop-S)) 
(papal !el 

(assign bb-s-offset (+ bb-s-offset (a-constant 8.))) 
(jump ub t tb t t-a i i gned-POu-soupce) ) ) ) ) 
;;Fpcib with what's left. Too bad dispatch blocke ape expen9ive, 
(If greater-or-equal-f ixnuB bb-width (a-constant (* 4 22.))) 
(sequential 

(assign b-temp (+ bb-s-offset (a-con9t3nt A))) 
(It (gpeatep-op-equal-f ixnura b-temp bb-s-pou-length) 
(goto ub I tb I t-a I i gned-pow-eoupce-s I ow- 1 oop) 
(sequent iai 

(assian-vma-of fset s 1) 
(parallel 

(assign a-temp (b-constant 4)) 
(assign b-temp obus) 

(stapt-memopy block read)) ;8tapt first wopd 
(para! leJ 

(uai ting-for-«emory) ;waiting for first word 

(start-memory blocK read) ;start second word 

(ca II ub 1 tb I t-b i ock-read-push-4) ) 
(para I lei 

(assign-vma-of f set d) 
(call 'ub i tb I t-b I ock-wr i te-poD-4) ) 
(paral lei 

(assign bb-s-offset (+ bb-9-offset (a-constant 4))) 
, (iumo ubi tb! t-al igned-pow-source-9iow-toop) )}) ) 
(goto ubi tbi t-al igned-pow-scupce-slow-ioop) J ) } 

(defucode ubi tbi t-al igned-pow-source-clow-loop ;9 cycles per word 

(paral I e I 31- 

(assign bb-width (- bb-width (a-constant 32.))) ;1 cucle 

(trap-if (minus-f ixnum obus) ubi to! t-a i igned-row-source-s low- loop-done) ) 
ifncr-wrap-s-offset) .2 

(paral lel-ui th-s-access *3 

bb-s-offset ' 

(assign bb-s-nord (logxor bb-constant memory-data))) 
(assign-vma-of fset d) -1 

(store-ucrd bb-s-word) II 

(parai lei li 
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I incr-d-ort'set/ 

(! i£p itrace-path tt/,)) 

(jump ubi tbi t-a! igned-rou-source-s tow- loop) )) 

(defucode ubl tb! t-al igned-row-source-s low- loop-done 
(trap-no-save) 
(if (pi us-f ixnum bb-width) 
(sequent iai 

( incr-wrap-£-Qf f set) 
(parai lel-ui th-£-acces3 
bb-s-of ftet 

(assign bb-s-uord (logxor bb-constant iiemopy-data) ) ) 
(paral let-wi th-d-access 
bb-d-offcet 

(assign byte-r (a-constant C) ) 
(asaicn byte-s (1- fcb-uidth)) 
(paral iel-wl th-return 

(stnre-wopd (dpb bb-s-uord bute-s bute-p fccmory-data)) 
(licp (trace-path U/2))))) 
(pare! le I -wl th-return 

(lisp (trace-path tt/l))))) 



;;Each pass through this loop stores exactly ona d word. Each time through. 
;;Db-s-word writ have the bits to use for the lower part of the d word (already 
:; rotated into position), and another s word will bo f<5tched into bb-'9-wcrd2. 
;;Then e-word2 will get rotated when transferred into s-word in preparation for 
;;next loop pass. 

(defucode ub i tb t t-d-a t ! cjned-row-source 

(if (greater-or-equal-f ixnum bb-width (a-constant (» S. 32.))) 

;;Fetch a block of words onto the block of araem past top of stack, and nove sp there, 
(sequent iat 

(assign b-temp (+ bb-s-of f set (a-constant 8.))) 
(if (greater-or-equal-f ixnum b-temp bb-o-row- length) 
(goto ubitblt-d-al igned-rou-source-s low- loop) 
(sequential 

(assirn-vma-of fset s 1) 
(psraliel 
(assign a-ter.p (b-constant 8.}) 
(assign b-tenp obus) 

(start-ncmory block read)) ;3tsrt first word 

(parai lei 

(waiting-f or -memory) ;waiting for first word 

(start-«eiBori4 block rc3d) ; start second word 

(ca II ub i tb I t-b i ock-rcad-push-8) ) 
(paral lei 

(sssign-vna-of f set d) 

(cat t ubi tbI t-d-a 1 igned-block-wri te-pop-8) ) 
(paral lei 

(assign bb-s-of f set (+ bb-e-offset (a-constant 8-))) 
(jump ubi tbl t-d-a I ignsd-row-source) ) ) H 
(if (greater-or-equaf-f ixnum bo-uidth (a-constant (» 4. 32.))) 
(sequent iaI 

(assign b-temp (+ bb-s-of f set (a-constant 4))) 
(if (greater-or-equal-f ixnum b-temp bb-s-row-length) 
(goto ub i tb I t-d-a I i gned-rcw-source-s I ow- 1 oopf 
(sequential 

(assian-vma-of fset s 1) 
(parallel 

(assign a-temp (b-constant 4.)) 
(assign b-terr.p obus) 

(start-memory block read)) ;start first word 
(paral lei 

(wai ting-fcr-memory) :waittng for first word 

(start-memory block read) jctort second word 

(cat I ubi tbl t-block-read-push-4}) 
(paral let 

(assign-vma-offset d) 

(cat I ubitblt-d-al igned-block-wri ts-pcp-4) ) 
(paral lei 

(assign bb-s-of fset (+ bb-s-of f set (a-constant 4,))) 
( iump ub i tb I t-d-a I i gned-row-source) ) ) ) ) 
(goto ubi tbl t-d-a I igned-row-source-s low- loop) ) ) ) 

(defmac-o def-d-a I igned-block-wri te-pop (name n) 
Mdetuccoe ,name 

(assign byte-s (1- bb-s-bi tpos) ) 
(assign byte-r (- (b-constant 32.) bb-s-bi tpos) ) 
.•(loop for i from n downto 1 
append * ( (paral lei 

(assign wemonj-data (dpb (amem (stack-pointer , (- (- n i)))) 

byte-3 byte-r bb-s-word) ) 
(start-memory block write) 
(i isp (trace-path ^/.))) 
- . ■ (assign bb-s-word (rotate (amem (etack-potnter , (- (- n i)))) byte-r)))) 
(assign stack-pomter 1- stack-pointer b-ter.piJ ^ 

(assign first-part-done (b-constant 0)) 
(assion ob-d-offset (+ bb-d-offset a-temp)) 
(paral I el-wi th-return 

(assign bb-uidth (- bb-width (rotate a-temp 5))) ;2^ - bi ts-p-r-wcrd 
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(d£f-d-al inncd-block-uri te-pcp ubi tbi t-d-at igned-blocK-wr i te»pop-8 8,) 
(cief-d-al igntd-blcck-wri te-pop ubi tbi t-d-al igned-biot;K-uri te-pop-4 4. ) 

(dcfuccde ubi tbI t-d-al igned-row-soupce-sl ow-lcop 
iparai lel 

(assign bb-uidth (- bb-utdth (a-ccnstan* 32.))) 

(trap- if (minu2-f ixnum cbus) ub i tb 1 t-d-3 1 igned-rou-soupce-done) ) ; aborts the assign 
( tr.;;r.wr£p-i;-of f set) 
(assinn-vma-of f set e) 
(parallel 

(assign byte-s (1- bb-s-bi tpos) ) 

(start-memory read) ) 
(parat lel 

(assign bLits-r (- (b-constant 32.) bb-s-bi tpos) ) 

(uai t ing-tcr -memory ) ) 
{3bus-array-d3ta 

(assign bb-s-word2 (logxor bb-constant tiemory-data) ) ) 
tassjcn-vr.a-of t£et d) 

(cxc-e-kcrd (dcb Db-3-uord2 byte-s byte-r bb-s-word)) 
( I ncr-a-cf f set ) 
lD3!-a; lei 

(assign bb-s-uord (rotate bb-s-uordZ Dyte-r)) 

( i isp' (trace-path #/. )) 

(jump ubi tbt t-d-al igned-row-source) ) ) 

{defucode ubi tb I t-d-al igned-rou-source-done 
(trap-no-save) 
(if (plus-fixnum bb-width) 
(sequential 

(ass ion a- temp (32- bb-a-bi tpos) ) jhou «any bits are valid in bb-s-uord 
(if tlesser-or-equa I -f ixnum ob-width a-temp) 
;;ue have enough s bits 
(para! iel-ui th-d-access 
bb-d-offsst 

(assign byte-s (1- bb-uidth)) 
(assinn byte-r (a-constsnt O) 
(paraT lel 

(I isp (trace-path U/i^)) 
(para I lel-wi th-return 

(store-word (dpb bb-s-uord byte-s byte-r aemory-data) ) ) ) ) 
;;need to get another source uord 
(sequent iat 

( incr-urap-s-of fset) 
(para ! ieJ -ul th-s-access 
tb-s-of fset 

(assign byte-r (32- bb-s-bi tpos) ) 
(assicT! byte-s (I- bb-s-bi tpcsl i 

(aEsign fcb-s-uord2 (lonxor bb-constant memory-data))) 
(assign"bb-s-ucrd (dpb bb-s-uord2 byte-s byte-r bb-s-uord)) 
(I isp (trace-path U/%)) 
(para I Iel-ui th-d-access 
bb-d-of fset 

(assign byte-s (1- bb-uidth)) 
(acsian byte-r (a-constant 0)) 
(paral Iel-ui th-return 

(store-uord (dpb bb-s-uord byte-s byte-r •ewory-data) ) ) ) ) ) ) 
(paral lel 

(i isp (trace-path U/2)) 
(return)))) 
;?alu depends only on destination bits 
(defucode ubi tbI t- tong-rou-dcst inat ion 
(if (bit f irst-part-done) 

(goto ubi tbi t-long-row-dest inat ion-pel sr-r est art) 
(if (p I us- f ixnum bb-d-bttpos) 

(sequentiai ; f rob the first partial uord 

(assign a-temp (32- bb-d-bi tpos) ) 
(ass tan byte-r bb-d-bi tpoc) 
Iparal ! e i -w i tif-d-accass 
bb-d-of fset 

(assign byte-s (1- a-ter.pH 

(assign b-temp (dpb bb-constant byte-s bute-r (a-constant 0) J ) 
(store-uord (logxor b-temp •emory-dats) ) f 
( incr-d-of fset) 
(paral lel 

(assign bb-uidth (- bb-uidth a-temp)) 
(I iso (trace-path n/t^)) 

(jump ubi tbI t-long-rou-dest ination-loop) ) ) 
(paral let 

(lisp (trace-path U/^)) • this debug crsp costs a cycle here, 

(jump ubi tbI t-long-rou-destination-Ioop))))) • should be goto, not jump. 

(defucode ub i tb i t- i ong-row-dest inat i on- i oop 

(if (greater-or-equal-f ixnum bb-uidth (a-constant (« 8. 32.))) 

;;Fetch a block of uords onto the block of aaen past top of stack, and Bove so there, 
(sequential 

(ass mn-vma-of fset d) 
(paral lel 

(assign a-temp (b-constant 8.)) 

(assign b-tenp obus) 

(start-memory bJock read)) ; start first word 
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(paraf lei 

(uai ting-for-menory) ;uaitmg for first uord 

(start-nemory bloc)', read? ; start second word 

(ca M ufc i to I t-b I ock-read-pu5h-8) ) 
" (carai lei 

iassi gn-vma-of f set d) 

<cal i-and-return-to ubi tbi t-btock-uri te-pop-8 

ubi tbi t-long-rou-dest inat ion-toop)}) 
;;Frob with what's left. Too bad dispatch blocks are expenstva, 
(if (greater-or-equal-f ixnum bb-width (a-constant (* 4 22.))) 
(sequent '. a\ 

(assi an-vna-of fset d) 
(paral let 

(assign a-temp (b-constant 4) ) 
(assign b-temp obus) 

(start-memory block read)) ;st3rt first word 
(paral lei 

(w3i ting-for-menory) ;waitinrj for first word 

(start-mefnory block read) :8tart second-word 
(cai I ubi tbi t-block-rcad-push-4)) 
(para I lei 

(assion-vma-of f set d) 

(ca) i-and-return-to ubi tbi t-block-wr i te-pop-4 
, ubt tbI t-long-row-destination-slow-jocp))) 

(goto ubi tbi t-long-rou-destination-slow-loop)) )) 

:: Write this when pcisring can happen 

(defucode ubi tb 1 1- long-rou-dest inat ion-pel sr-restart 

(i isp (tel l-the-5iru(ator-that-it-is-Gupposed-to-halt-the-Bjachine)) 

(halt bi tbt t-pci sr ing-now-yet-wr i tten) ) 

(defucode ubi tbt t- I ong-row-dcst i nation-si ow-(ocp 
(paral let 

(assign bb-width (- bb-width (a-constant 32.)?? 

(trap-if (minus-f ixnufii obus) ubi tbI t-long-row-dectinat ton-done) ) ;eborts the assign 
(I isp (trace-path s?/,)) ^ 

(paral lei-uitn-d-access 
bb-d-of f set 
(»ncr-d-of fset) 
(paral let 

(stcre-ucrd ( i o^xor bb-ccnstant rremory-data) ) 
(jump ubi tbI t-long-row-desti nation-stow- loop) ))) 

(defucode ubi tbI t- long-row-dest I nat ion-done 
(trap-no-save) 
(if (plus-fixnuffl bb-width) 
(sequent iai 

(assion byte-r (a-constant 0)) 
(paral iel-ui th-d-access 
bb-d-off«et 

(assign byte-s (1- bb-width)) 

(assian b-temp (dpb bb-constsnt byte-s byte-r (a-constant 8))) 
(par 3 1 tel 

( I isp (trace-path n/2) ) 
(paral lel-wi th-rcturn 

(store-word (logxor b-tcmp menory-data) ) ) ) ) ) 
(paral let 

(1 isp (trace-path H/D) 
(return) ) } ) 

(defaacro def-btock-read-push (name n) 
'(defucode ,n3me 

,«(loop for i from n downto 1 
col tec t '(paral iei 

(dec t are-memory- 1 i m i ng data-cyc 1 e) 
(check-data-tupe seRiory-data dtp-fix) 
(assign (amem (stack-pointer ,i}) 

(logxor bb-conotant »etnory-data) ) 
.(when (> i 2) * (start-weoory block read)))) 
(assign first-part-done (b-constant 1)) 
(paral lel-wi th-return 

(assign stack-pointer (+ stack-pointer b-tempM)}l 

(def-block-read-push ubi tbI t-block-read-push-8 8) ;I suppose this when interned... 
(def-block-read-push ubi tbi t-block-read-push-4 4) ;... will subsunie this. 

(def macro def-block-wr i te-pop (name n) 
'(defucode .name 

.•(loop for i from n downto 1 
col lect * (paral let 

(assign memory-data (amen (stack-pointer , (- (- n i))))) 
istart-memory block write) 
(iisp (trace-path ft/,)))) 
(assign stack-pointer (- stack-pointer b-te»p)) 
(assign first-part-done (b-constant 8)) 
(assign bb-d-offset (+ bb-d-offset a-temp) ) 
(paral lel-wi th-return 

(assign bb-width (- bb-width (rotate a-temp 5))) ;2*S - bi ts-per-word 

(def-block-wr t te-pop ubi tbl t-block-wr i te-pop-8 8) 
(def-block-wr i te-pop ubi tbt t-block-wr i te-pop-4 4) 
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;;aiu depends on neither source nor destination bits 
idefucode ubi tbi t-tong-row-nei ther 
(if {pius-fixnum bb-d-bitpos) 
-(sequential 

iassiqn a-temp (22- bb-d-bitpos)) 
(par a I lei -ui th-d-access 
bb-d-offset 

(assign byte-r bb-d-bitpos) 
(assign byte-s (1- a-temo)) 

(store-uord (dpb bb-conctant bute-s byte-p memoru-data) ) ) 
(incr-d-offset) 
(para I iel 

(assign bb-width (- bb-wtdth a-temp)) 
(lisp (trace-path tf/b)) 
(jump ubi tbi t-lonq-rou-nei ther- 1 cop)}) 
(parallel 

(I isp (trace-path tf/a)) 

( juKp ub i tb 1 1- i ong-pou-ne i ther- 1 oop) ) ) ) 

(def ucode ub i tb 1 1- 1 ong-rou-ne i ther- 1 oop 

(if (gpeatep-op-equal-f ixnuni bb-width (a-constant (» S. 32.))} 
(sequent i al 
Iparal let 

(assign-vma-of fset d) 
(cal I atore-block-bb-conetant-S)) 
iassign bb-d-offset U bb-d-offset (a-constant 8.))) 
(paral Iel 

(assign bb-width (- bb-uidth (a-constant (» 8, 32.)))) 
(jump ubi tbI t-long-pQw-nei thep-Ioop))) 
(sequential 

(dispatch-aftep-next (parallel (assign a-temp (Idb bb-width 2 5)) 
,„. . ,, , , (Idb bb-width 3 S)) 

((7) (papallel (ass ign-vma-of feet d) 

(cal l-and-return-to etore-block-bb-constant-? 
ttc.f , , . , ub i tb 1 1- 1 ong-pow-ne i thep-f i n i sh) ) ) 

((B) (parallel (assign-vma-of fset d) 

(cal l-and-petupn-to stopc-block-bb-constant-S 
t tc\ t ^ I I t f . ubi tb I t-tong-row-nei thep-f inish))) 

((5) (papallel (assign-vma-of fset d) 

(cai l-and-retupn-to stope-block-Lb-constant-S 

((4) (papallel (ass ign-vma-of fset d) 

(cal l-and-retupn-to stope-b!ock-bb-constant-4 
, ,-, - . , . , ub i tb 1 1- 1 cng-pow-ne i thcp-f i n i sh) ) ) 

((3) (parallel (assign-vma-offeet d) 

(cai 1-and-petupn-to 8tope-block-bb-constant-3 
,,-, t ., r f ubitblt-long-pow-netthep-f inish))) 

((2) (paraMel (assign-vma-of fset d) 

(cat i-and-retupn-to 8tope-block-bb-con9tant-2 
,,,, , ^^ . ^. ubitblt-long-pow-neithep-finish))) 

((1) (ass tgn-vma-of fset d) 
(parat Iel 

(i isp (trace-path Af/J) 
(stope-uopd bo-constant) 
(jump ubitblt-long-row-neither-f inish))} 
(othepuise (goto cant-happ^n) ) ) 
(if (zero-fixnum a-temp) 

(gcto ubi tbI t-!ong-pow-nei thep-f inish) 
(take-dispatch))))) 

(def ucode ubi tbt t-1 ong-rou-ne i thep-f inish 
(assign bb-d-offset (+ bb-d-offset a-terrpi) 
(assign bb-width (logand bb-width (a-constant Uo27))) 
lif (plus-fixnum bb-utdth) 
(papal lel-wi th-d-acces5 
bb-d-offset 

(assign bute-p (a-constant 0)) 
assiqn byte-s (1- bb-uidth)) 
(papal lei 

(I isp (tpace-path tf/2)) 

(stope-wppd (dpb bb-constant byte-e byte-p memopu-data) ) 
(petupn) )} =» » 

(papal Iel 

(I isp (trace-path ff/D) 
(return)))) 

(defmacro store-b lock-bb-constant-rout ines (n) 
tppogn compi ie 

••(loop with s - "STCRE-BLOCK-EB-CONSTANT-vd" 
fop i fpom n downto 1 
collect Mdefucode .(fintepn s i) 
(papal Iel 

(assinn memopy-data (set-type bb-constant dtp-fix)) 
, ( I f (> 1 1) 

' (stopt-memopy block wpite) 
• (start-memory wri te)) 
(lisp (trace-path fr'/J) 
.(if (> i 1) 

'(jump , (f intepn s (1- i))) 
•(return))))))) 
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jbb-al rgned-rou-both ui ! ! increment first 



;;alu depends both source and destination bits 
(defucode ubi tb! t-long-rou-bcth 
(para lie! 

(assign b-temp bb-d-bitpos) 
(if (zero-f ixnum bb-d-bitpos) 

(if (rero-fixnum bb-s-bitpos) 
(para I lei 

( t isp (trace-path t$/a) ) 
(asctgn bb-s-offset ii- bb-s-of fact) ) 
(junp ubi tbi t-3l igned-row-both) ) 
(parai lel-ui th-s-access 
bb-s-offset 

: ; SSSSSSSSSSSSSSSSSS^.^SSGSSSSS. ssss 
; ; dddddddaddcddddddciddcicljdciddddddd. 
(ass i en byte-r (32- bb-s-bi tpos) ) 
iparalief 

(assign bb-«-uord Uogxar bb-constant (rotate ■emory-data bute-r))) 
(lisp ttrace-p2th flf/cM 
, ( iump ubi tbft-d-a! igned-row-both) ) ) ) 
(if (equal-f jxnua bb-s-bitpos b-temp j 
(sequential 

(para I ( e t -u i th-s-access 
bb-s-offset 

; ; £SSS3SSE53?SSSSSS332SSSSSS, ssssss 
; ; dddddddddddddddddddddddddd. dddddd 
(pcrat lei 

(assign byte-r (32- bb-s-bi tpos) ) 
(assign a-temp obus)) 
(assign byte-s (31- bb-s-bi tpos) ) 



(assign bb-s-ucrd (logxor bb-constant (Idb acfflopy-data bute-s bute-r 
(assign byte-p bb-s-oitpos) » » » 

(paralie! 

(assign-vrna-cf fset d) 

: ; 55ssss5ssssss5?5$ssssss9ss. esssss 

;; DDDDDDDDDDDDDDDDDDDDDDDDDD. dddddd 

(cai I bb-bu re-a I u-Qper at ion-dispatch) } 
( incr-d-of f set) 
(para I Id 

(assign bb-width (- fcb-uidth a-temp)) 

(I isp (trace-path #/b) ) 

(iunp ubitblt-al tgned-row-both))) 
(if (lesser-f ixnum bo-s-bitoos b-teirp) 

(goto ubi tbi t-long-pow-both-s- longer) 

(goto ubi tbI t-long-pow-both-s-ehorter))))}) 

(defucode ubi tbI t-long-rou-both-s-Ionger 
(assign a-teiRp (32- bb-d-bitpos)) 
(paraT I e I -w i th-s-access 
* bb-s-offset 

(assign byte-r (32- bb-s-bi tpos) ) 

(assign byte-s (1- a-temo) ) 

^^ssASui^ES*=r"oi:SS. *'cnxor bb-constant «e»ory-data) ) ) 

; . ss5sSr.355S5£S5S3SS3S'^-33 

:; DDDDDDDDDODDDDDDDDDDdddddddddddd 

;; 4 a-temp » 

(assign bb-s^word (rotate bb-s-wcrd2 bute-p)/ 

; ; »5ssS3S3£SSSSS5£S3SSSSSS 

(assign byte-r bb-d-bitpos) 
(parallel 

(assign-vma-of fset d) 

: ; ssscssssssssssssssssssss.essssscs 

; ; DDDDDDDDDDDDDDDDuDDD. dddddddddddd 

(cal I bb-byte-aiu-operat^on-dispatch)) 
(tncr-d-offset) 

;:Remainlnq are (31-(s,bi tpos+(32-d.bt tpos))) - d.bi tpos-s.bi tpos 
5'-^^*""" 32-d. bf tpos -♦ *-- s.bitpcs— ► 

;;5S5S£SSSSS5SSSSSC5SSSS35.8SESSSSS 

; ; ddddddciddddddddddddd. dddddddddddd 
(assign b-tccp bb-s-bi trDos) 
(assign byte-r (- bb-d-bitpos b-terp)) 
(assign bb-s-word (rotate bb-s-wcrci b-Jte-r)) 
(assign bb-uidth (- bb-uidtn a-ter.p) ) 
(oaroT let 

(assign bh-s-bitpos (+ b-ter.p a-tcnp)) 

(I isp (trace-path tf/d) ) 

(jump ubU^ti t-d-ai igned-pou-both) ) ) 
(defucode ubi tbl t-long-pou-both-s-ahoptep 

;; BSSSSSSSSSSSSSSSSSSSSSSS. 888SSSSS 

; ; dddddddddddddddddddddddddddd. dddd 
(para I fe l-ui th-s-access 

bb-s-of fset 

(assign byte-p (32- bb-s-bi tpos) ) 

(assign byte-s (31- bb-s-bi tpos) ) 

;; S3SSSSSSSSSSSSBSSSSSSSSS.8SSSSS88 

; ; dddddddddddddddddddddddddddd. dddd 

(assign bb-s-wopd (logxop bb-constant (Idb Msopy-data bute-s bute-p)))) 
(mcp-urap-s-of fsat) ^ 

;; * ► s.bi tpos-d.bi tpos 

; ; . . .SSSSi SSSSSS99SSS5SS3SS5SSSS9S. S5SSSSSS 



-p)))) 
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;; dddd dddddadddcJdddddddddddddd.dddd 
(assign b-temp bb-d-bi tpos) 
IparaT le l-wi th-s-access 
bb-s.-of fset 

(assign byte-s (- bb-s-bitpos b-temp 1)) 
(assign byte-r (32- bb-s-bitpos)} 

(ass ion bb-s-word2 (looxcr bb-constant »emoPu-data) ) ) 
; ; . . , S£:;S i SSSS3S55SSSSS3S53SS£3SS5. ssssssss 
;; dddd dddddddddddddddddddddddd.dddd 

(assign bb-s-uord (dpb bb-s-uord2 byte-s byte-r bb-s-uord) ) 
(assign byte-r bb-d-bitpos) 
(assign byte-s (31- bb-d-bitpos)) 
; ;... ssss I S5S5SSSSSSSS55SSSS3SSSSS. ssssssss 
;: DDDD DODDDDDDDDDDDDDDDDDDDDDO.dddd 
(para I lei 

(assign-vraa-of fset d) 
(cat I bb-byte-a I u-operat ion-dispatch) ) 
(incr-d-of fset) 

; ; . . .SSSssssI SSSS5SSSS99SSSSSSSSSSSSS. ssssssss 
:: dddd dddddddddddddddddddddddd.dddd 

(assign a-temp (32- bb-d-bitpos)) ;Try to find so«e more cleverness here. 

(assign bb-wtdth (- bb-width a-temp)) 
(assign b-temp bb-d-bitpos) 
(assign byte-r (- b-temp bb-s-bitpos)) 
(assign bo-s-bitpos (- bb-s-bltpos b-temp)) 
(paraTle! ^ 

^assign Db-5-uord (rotate bb-9-uord2 byte-r)) 
(i isp (trace-path ff/e)) 
-: jump jJtJjJbJJ-d-al igned-row-both) ) ) 
(defucode ubi tb! t-al igned-rou-both 

(If (greater-or-equai-f ixnura bb-uidth (a-constant (« 8. 32.))) 

;;Fetch a block of words onto the block of «aea past top of stack, and «ove «p there, 
(sequent iai 

(assign b-temp (+ bb-s-offeet (a-constant 8.))) 
(if (greoter-op-equ3i-f ixnuo) b-temp tb-s-rou- length) 
(goto ubi tbt t-3/ jgned-row-DOth-atou-/cop) 
(sequential 

(assion-vma-of f set s 1) 
(paral lei 

(assign a-temp (b-constant 8.)) 
(assign b-temp obus) 

(start-memory block read)) tstart first word 

(paral tel 

(uai t ing-for-memory) ;waiting for first word 

(start-memory block read) ; start second word 

(call ubi tbi t-biock-read-push-8)) 
(assign-voa-of f set d) 

(dispatch-af ter-this (Idb bb-alu-operat ion 4 0) 
(para) I el 

(assign a-temp (a-constant 8.)) 
(assign b-temp (a-constant 8.)) 
,,, ^, (start-aemory block read)) ;8tart first word 

((12) ; ; x«y '^x^y 

(goto ubi tb! t-block-logand-8)) 
((4 8.) ;; x^c^-y *^xi-»u 
(ooto ubi tblt-block-andc2-8)) 
((S3.) ;; X xor u, ^x xor y 

(aoto ubi tbi t-block-Togxor-S)) 
((7 11.) ;; x+y, «x+y 

(goto ubi tbI t-block-logior-8)) 
((13. 14.) ;; ^(-x*u), -v(x«u) 
(goto ubi tbI t-block-lognand-S) ) 
(otherwise (goto cant-happen)))))) 
;;Frob with wh3t*s left. Too bad dispatch blocks are expensive. 
;;()f (greater-or-eau3i-f ixnum bb-width (a-constant (» 4 32.))) ..,) 
(goto ubi tbt t-at igned-rou-both-slow-loop))) 

(def macro def-block-aluop (name n alu ^optional complement) 
•(defucode ,name 

,«(loop Tor i from n downto 1 
append * ( (paral lei 

(dec tare-memory-timing active-cycle) :wait for first word 
(wai t ing-for-memcry) 

(assign b-temp-2 (amea (stack-pointer , (- (- n i)))))) 
.•(if (not complement) 
* ( (paral lei 

(abus-arraij-data (assign (amen {stack-pointer ,i)) 

(•alu b-temp-2 aemory-data) ) ) 
, (when (> t 1) 

•(start-memory block read) ; start next word 

' ( (abus-crray-data (assign a-temp-2 

(,alu b-temp-2 aemory-data)) ) 
(parallel 

(assign (amem (stack-pointer ,i)) 

(logxor a-temp-2 (b-constant -1))) 
, (whsn (> i 1) 

'(etart-aemopy block read) 
)))))) 
(oarai let 
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(assign stack-pointer U »tacK-po inter b-temp)) 
(jump ,(f intern "UBlTELT.BLOCK-ALU-URITE.-.d" n))))) 

(def-biock-aluop utsi tb! t-biock-lcgand-S 8 loganrf) 
(cjef-b'lock-aluop ubl tbi t-block-logicr-S 8 logior) 
(csf-block-a!ucp ubi tbi t-block-lcgxop-S S iogxor) 
(def-block-aiuop ubi tbi t-block-andc2-8 & anoc2) 
(def-btock-aluop ubi tbi t-b/ock-tognand-u 8 logand complement) 

(def macro def-block-af u-wr i te (name n) 
Mdcfucode ,name 

(assign-vms*of f set d) 
.•(loop for i from n dovmto 1 
collect '(parallel 

(assign memory-data (amem (stack-pointcp . {- t- n i))})) 
(start-memory block write) 
, (lisp (trace-p2th tf/,)))) 

(ascjgn stack-pointer i- stack-p.o inter (rotate b-temp 1))) 
(assign first-part-done (D-con5t^nt 0)) 
assign bb-d-offi%t {+ tr.-d-offset a-tcmp)) 

assicn bo-uidth (- bb-uidth (rotate a-tcrcp 5))) :2^ - bi ts-per-uord 
ipara Mel 

(assign bb-s-offset (+ fcb-s-offtet a-temp)) 
(jump ubi tbi t-ai igned-row-both)))) 

(def-block-alu-uritc ubi tbi t-block-a!u-wr i te-8 8) 

^^^I'^^r? V^'^'^*^"®''^'^*'^'''°^"^°^^-^'*=^^^-*°°P ;11 cucles per word, or 12 for nand 
iK3ra I t e I , j ^y^ j q 

(assign bb-uidth (- bb-width (a-constant 32. i)) 

(trap-if («tnus-fixnu» obus) ubi tbi t-al igned-row-both-slow-loop-done) ) 
(incr-urap-s-of fset) ;2 cycles 

(paral lei-wi th-s-access ;3 cycles 

bb-«-off5ct 

(assign bb-s-uord (Iogxor bb-constant «e«ory-data) ) ) 
(parallel ;l+3 cyciec. or 1+4 for nand 

tassign-vma-of f set d) 

(cat I iDb-uord-alu-operat ion-di spatch) ) 
(paral tel ;1 cycle 

(incr-d-of fset) 

(tisp (trace-path tf/^)) 

(juap ubi tbi t-at igned-rou-both) } ) 

(defucode ubi tbi t-al igned-row-both-slow-loop-done 
(if (plus-fixnum bb-width) 
(sequential 

( incr-urap-s-of fset) 
(para I I e i -w i th-s-access 
bb-s-offset 

(ass ion byte-r (b-constant 0)) 
(assign byte-s (1- bb-width)) 

(assign bb-s-word (Iogxor bb-constant •emoru-data) ) ) 
ipara\ lei 

(I isp (trace-path n/2)) 
(ass ign-vma-of fset d) 

(jump bb-byte-aiu-operat ion-dispatch))) ;jcall 
(paral iel-wi th-return 

(lisp (trace-path tf/1))))) 

Each tiae through the loop, s-word was fetched froa Bemopy like 
< s, b i tpos -* 

8S8SSSS8SS 

and then rotated so it looks like 

SSSS5S39SS 

♦. -s.bi tpos -» 

Each tiae, another s-word2 gets fetched and deposited into s-uord like 
1 4 5,bi tpos ► 

2222222222 2222222222222222222222 

The rotation for the dpb equals the rotation for setup for next loop. 

(defucode ubi tbi t-d-at igned-row-both 
(parai lei 

(assign bb-width (- bb-width ia-constant 32.))) 

(trap-if (minus-f ixnum obus) ubi tbi t-d-ai tgned-rou-both-done) ) ;aborts assign 
( incr-urap-s-of f set) 
(parat tei-ui th-s-access 

bb-s-offset 

(assign byte-r (32- bb-s-bi tpos) ) 

(assign byte-s (1- bb-s-bi tpos) ) 

(assign bb-s-word2 ( i oqxor bb-constant «efflory-data) ) ) 
(assign fcb-s-uord (dpb bb-s-word2 bute-s byte-r bb-s-word)) 
(paral Icl 

(assign-vma-of f set d) 

(cal I bb-word-a i u-operat i on-di spatch) ) 
{ mcr-d-of f set) 
(paral le! 

(assign bb-s-word (rotate bb-s-word2 byte-r)) 

(I isp (trace-path »/.)) 

(juep ubi tbi t-d-aligned-row-both))) 
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;At entrg, ue have s-uord fetched from aeaory like 
; •- s.bitpos ► 

; S8SS9S5SSS 

:t)ut then rotated so it looka like 

; 88SSSSS559 

; « 8. b i tpOS -• 

« 

;Thl8 is to br combined with d-word which looks like 

; dddriddddddad 

; i width — -* 

(de f ucode ub i tb 1 1 -d-a i i gned-pou-bo th-done 
(trap-no-save) 
(if (plus-f ixnum bb-width) 
(sequent ia I 

(assiqn a-temp (32- bb-s-bi tposl 1 
(if (Tesser-or-equai-f ixnum bb-width a-tenp) 
;;we have enough s bits 

* ; 4 6- b i tpos ►^ a. temp -♦ 

; ; • - • • essssssssssssss 

; ; dddddddddddd 

;; 4 width — ► 

(sequential 

(assign byte-p (b-constant B)) 
(assinn byte-s (1- bb-width)) 
(parallel 
(assian-vma-of fset d) 
(lisp (trace-path #/4)) 

{>ump bb-byte-a I u-operat ion-dispatch))) jjcall 
;;need to get another source word 

i;* tt^bi tpos M a. temp -» 

; ; sasesssssssssss 

; ; dddddddddddddddddddd 

: ; ^ width • 

(sequent iai 

(incr-wrap-s-offset) 
(para I lel-wi th-s-access 
bb-s-offset 
(assign byte-r a-temp) 
(assign fcyte-s (1- bb-s-bl tpos) ) 

(assign bb-s-word2 (Jogxor Bemory-data bb-constant) ) ) 
(assign bb-s-word id^b tb-s-wordZ byte-s byte-r bb-s-word)) 
(assign bute-r (b-constant 0)) 
(assion fcyte-s (1- bb-width)) 
(paral lei 
(assign-vma-of fset d) 
(I isp (trace-path U/S)) 

(jump bb-byte-alu-operation-dispatch))))) ricall 
{para\ lel-wr th-return ^ 

(lisp (trace-path X?/3))))) 
(def ucode ub i tb 1 1- I ong-row-source-backwcrds 
(paral lei 

(assign b-tenip bb-d-bitpos) 
(if (zero-fixnuB bb-d-bitpos> 

(if (zero-f ixnun bb-s-bftpos) 
(paral tel 

(assign bb-s-offsel (1+ fcb-s-of f set) ) ;the loop will deer first 
(I isp (trace-path *1/a) ) 

( jump ub i tb I t-a i i gned-rcw-souPce-backw3rds) ) 
(sequent iaI 

(paral le!-wi th-s-access 
bb-s-offset ' 

(assign byte-r (32- fcb-s-bi tpos) ) 
(paral iei 

(assign bb-s-word (lonxor bb-constant (rotate memory-data byte-r))) 
(I isp (trace-path ^/cU 

(jump ub i tb I t-d-a 1 i gned-row-source-bacfcwards) ) ) ) ) 
(if (equal-f ixnum b-temp bb-s-bitpos) 
(sequential 

(paral lel-wi th-s-access 
bb-s-offset 

(assign byte-s (1- bb-s-bitpos)) 
(assign byte-r (b-constant 8)) 

(assign bb-s-word (logxor memory-data bb-constant))) 
(paraS iei-wi th-d-3ccess 
bb-d-offset 
(decr-d-of fsetl 

(assion bb-width (- bb-width bb-a-bi tpos) ) 
(paral lei 

(store-word (dpb bb-s-word byte-., byte-r «cmopy-data) ) 
(lisp (trace-path tf/b) ) 

(jump ub i tb I i~a I i gned-rou-source-backuards) ) ) ) 
(if (gpeater-f ixnum bb-s-bitpos b-temp) ;s > d, enough in the current wopd 
(sequent iaI 

(para i I e t -w i th-s-access 
bb-s-offset 

(assign bb-width (- bb-width bb-d-bitpos)) ;has to be done sowewhepe 
(assign bb-s-word (logxor bb-constant Kemory-data) ) ) 
(paral !e!-wi th-d-access 
bb-d-of fset 
(assign byte-s (1- bb-d-bi tpos) ) 
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Cassign byte-r (- b-temp bb-s-bi tpos) ) 

(store-word (Idb bb-»-uord byte-9 byte-p »cmoru-data) ) ) 
(assign bb-9-woPd (rotate bb-s-uord byte-r)) 
(assign bb-s-bitpos (- bb-s-bitpos b-terap)) 
(parallel 

(decr-d-offset) 

(I isp (trace-path AVd) ) 

(jump ubi tbl t-d-al igned-rou-soupce-backwapds))) 
(sequential ;8 < d. need to fatch anothep wopd 

(para I le!-ui th-s-access 

bb-9-offsst 

(assign byte-p (- b-temp bb-s-bl tpcs) ) 

(assign bb-s-uopd ( iogxop bb-constant (rotate •cnopy-data bgte-p)))) 

(papal lel-ui th-s-access 

bb-s-offset 

(assign a-tcmp (- b-temp bb-s-bi tpos) ) 

(assign byte-s (1- a-tcmp)) 

(assign bb-s-wopdZ (logxor bb-constant wetRory-data) ) ) 
(ass inn bb-s-word (Idb bb-8-uoPd2 byte-s byte-p bb-s-wcrd) ) 
(papa ! I e I -w t th-d-access 

bb-d-offset 

(assign byte-r (b-ccnstant 8)) 

(assign byte-s (1- bb-d-bi tpos) ) 

(store-uord (Idb bb-s-wopd byte-s byte-p nemory-data) ) ) 
(assign bb-utdth (- bb-uidth bb-d-bi tpos) ) 
(assign fcb-s-bitpos (32- a-temp)) 
(assign byte-p a-terr.p) 

(assign bb-s-wopd (rotate bb-8-wopd2 byte-r)) 
(papal !e I 

(decr-d-offset) 

(J icp (trace-path #/e) ) 

yi!!!!^__y.^JJAi*""^"'a' igned-row-source-backuards) ))_))))) 

(defucade ubi tbi t-aligncd-rou-source-bcckuards ;8 cycles per uord 
ipar a t I e I • ^ 

(assign bb-uidth (- bb-width (a-constant 52. b) 

(trap-if (minus-f ixnua obus) ubi tol t-al igned-row-soL-rce-backwards-rtone) ) 
idccr-wrap-9-of f set) ;1 

(paral lel-ui th-5-acces9 ;3 

bb-s-offset 

(assign bb-s-word (logxor bb-constant ■emory-data) ) ) 



(acsign-vBa-of f set d) 

(store-wcrd bb-s-word) 
(parai lei 

(decr-d-offset) 

(i isp (trace-path #/, ) ) 

(ju»p ubi tbi t-3f igned-roM-aource-bacKwards))) 



(de f ucode ub i tb I t-a 1 i gned-pou-eource-bcckuapds-done 
(tpap-no-save) 
(if (Dius-fixnum bb-uidth) 
(sequent iat 

(dccr-urap-s-of f set) 
(para! lei-wi th-s-acces3 
bb-s-of f set 

(assign byte-s (1- bb-width)) 
(assign byte-r bb-uidth) 

(pa^Illfl-SuhlS-acciis^**^'' t)b-constant (Idb «emory-data byte-s byte-r)))) 
bb-d-offset 
(assian byte-r (- (a-constant 32.) bb-uidth)) 

(paral lel-wi th-return 

( 1 i sp']tr%ce-pi?h''^72'rm ) ""**■' ""^''^ ««ory-dat3) ) 
(paral lel-wi th-return 

( I i sp ( tj^e-path tf/ l))) )) 
:;each time throi/nh the loop, bb-s-word has the tow p-rt of the previous word 
;; rotated to be at the high end of the word. Ue use it as background to LD3 the 
;;high part of the next word into it* 

(defucode ubi tbi t-d-al igned-row-source-backuards ;S cycles cer uord 
tparaliel ^ -1 cycle 

assign bb-utdth(- bb-uidth (a-constant 32.))) tassiqn is aborted if trap occurs 

(trap-if (minus-ftxnum obus) ubi tb I t-d-a I igned-row-source-backuards-done) ) 
idecr-wrcp-E-of fset) ;2 

(paral lel-ui th-s-access |3 

bb-s-offsat 

(assign byte-r (32- bb-s-bi tpos) ) 

(assign byte-s (31- bb-s-bi tpos) ) 

(assign bb-s-word2 (logxor bb-constant nemory-data) ) ) 
(assign-vma-of f set d) .-l 

(store-word (Idb bb-s-word2 byte-s byte-r bb-s-word)) :1 
(decr-d-offset) •! 

(paral lei li 

(assign bb-9-word (rotate bb-e-word2 bute-r)5 

(I isp (trace-path tf//]] 

(jump ubi tbl t-d-ai i^ned-row-source-backuards) ) ) 

(de f ucode ub i tb I t-d-a I i gned-row-source-backwards-done 
itraD-no-save) 
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(if (p ius-f ixnutn bb-uidth? 

(If (greater-or-equai-f ixnum tiD-s-bi tpoa bb-u'idth) 
(para I le!-ui th-d-access 
bb-d-offset 

(assign byte-r (b-constant 8)) 
(assinn byte-s (- (a-constant 31.) bb-uidth)) 
(paral ie) -wi th-return 

(store-word ( I db memorij-data bute-5 byte-r bb-s-uord)) 
(Mcp (trace-path «/4) ))) 
(sequential ' 

(decr-wrap-s-of f set) 
(parai !ei-ui th-s-access 
bb-s-of f set 

(assign byte-r bb-uidth) 

(assign bb-9-word (rotate bb-s-word byte-r)) 
(assign bb-s-word2 (logxor bb-constant ueracry-data) ) ) 
(parallel 

(assign byte-r (- bb-width bb-s-bi tpos) ) 
(assign a-tenp obus) ) 
(assign byte-s (1- a-temp)) 

(assign bb-s-uord (Idb bb-s-uord2 byte-s byte-r bb-s-word) ) 
(par a I le l-wi th-d-access 
bb-d-offset 

(assign byte-s (1- bb-width)) 
(assiqn byte-r (- (a-conctant 32.) bb-uidth)) 
(para I i el -ui th-return 

(store-word (dpb bb-s-uord byte-s byte-r memory-data)) 
(lisp (trace-path U/S)))))) 
(para! !el-wi th-return 

(lisp (trace-path j;r/3))))) 

(de f ucode ub i tb f t- I ong-rou-both-backwards 

(paral lei 

(assign b-temp bb-d-bitpos) 
(if (zero-fixnua bb-d-bitpos) 

(if (zero-f rxnu» bb-»-bi tpos) 
iparai iei 

(assign bb-9-cffset (1+ tb-s-of f sat) ) ; (cop ui ) i deer first 
(lisp (trace-path tf/aU 

(jump ubi tbi t-a! igned-row-both-bacicwards) ) 
(paral lel-ui th-s-access 
bb-s-of fset 

(assian bute-r (32- bb-s-bi tpos) ) 
(paraT tel 

(assign bb-s-uord (lonxor bb-constant (rotate memory-data bijte-r))) 
(lisp (trace-path ti/c)) 

(Jump ubi tbI t-d-al igncd-rou-both-backwards)))) 
II f lequal-f ixnuw b-temp bb-s-bi tpos) 
(sequent ia) 

(parai le!-ui th-a-access 
bb-s-of fset 

(assign byte-s (1- bb-s-bi toos) ) 
(assign byte-r (b-conctant 6)) 

(assign bb-s-word (logxor bb-constant memory-data))) 
(assign-vma-offset d) 
(paraTlet 
(decr-d-offset) 
(start-remcry read) 

(call bb-byte-3iu-cperat ion-dispatch)) 
(parafiel 

(assign bb-uidth (- bb-uidth bb-t-bi tpos) ) 
(lisp (trace-path #/b}) 

(jump ubi tbit-al igned-row-both-backwards))) 
(If greater-fixnuB bb-s-bitpos b-temp) m > d. tnough in first uord 
isequent i al 

(paral lel-uith-s-accesc 
fcb-s-offset 
(paral tel 

(assign byte-r (- b-temp bb-s-bi tpos) ) 
(assign a-temp obus)) ;thi3 is negative 
(assign byte-s (1- bb-d-bitpos)) 

(assign bb-s-uord (tcgxor bb-constant (rotate memory-data byte-r)))) 
(assign byte-r (b-constant 0)) ^ < w/ 

(paral lei 

(assi gn-vma-of fset d) 
(call bb-byte-alu-oberat ron-dispatch) ) 
(assign bb-uidth {- bo-uidth bb-d-bitpos)) 
(assign b-temp bb-d-bitpos) 
(assign bb-s-bitpos (- bb-a-bitpos b-temo) ) 
(parallel 

(decr-d-offset) 
(I isp (trace-path tf/ti)) 

(jump ubitblt-d-a! igned-row-both-backuards))) 
(sequential ;g<d, need to fetch another uord 

(paral iel-wi th-s-access 
bb-s-offset 
(assign byte-r (- b-temp bb-s-bitpos)) 

frilnt^'^^^ bb-s-word (logxor bb-constant (rotate »emory-data byte-r)))) 
* uscr— wrap— s— 0* f se t / 
iparal lei -wi th-s-access 
bb-s-offset 
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(assign a-temp {- b-tenp bb-s-bi tpos) ) 

(assign fcyte-s (1- a-terrp)) 

(assign bb-s-uord? (logxor bb-constant »ei?oru-data)) ) 
assign bb-s-uord (Idb bb-B-ucrd2 byte-s bute-p bb-s-uopd) ) 
acsign byte-3 (1- bb-d-bitnosM 
(assfgn byte-r (b-constant CH 
(parallel 

(assicn-vnra-of f set d) 

(cai I bb-byte-a I u-operat ion-dispatch) ) 
(assign bb-width (- bb-width bb-d-bi tpos) ) 
(assicn b-temp bb-d-bitpos) 
(parallel 

(assign b-temp (- b-temp bb-s-bi tpos) ) 

(assign byte-r obus)) 
(assign bb-s-word (rotate bb-9-iJord2 byte-r)) 
(assron bb-s-bitpG3 (- (a-constant 32J b-temp)) 
(paraTict 

(decr-d-of fset) 

(lisp (trace-path tf/e)) 

i jump ub i tb I t-d-a 1 i gned-row-bo th-backwards) ))))))) 

(defucode ubi tbt t-al igned-rou-both-backuards jl0 cycles per word 
(para I 1 e I • \ 

(assign bb-uidth (- bb-uidth (a-constant 32. b) 

(trap- if (minus-fixnum obusJ ubi tbi t-al igned-row-both-bacKuards-done) ) 
(decr-wrap-s-offset) .1 

(paral let-ui th-s-acceas .3 

bb-9-offset 

(assign bb-s-uord (logxor bb-constant «eBoru-data) ) ) 
(parallel ;l+3 

(assign-v»a-of f set d) 

(cal I bb-uord-alu-operatton-disparch>> 
(para) let •! 

(decr-d-offset) 

(i isp (trace-path #/J) 

(jufpp ubi tbi t-al igned-row-both-backuards))) 

(de f ucode ub t tb I t-a I i gned-row-bo th-backwards-done 
(1^ (plus-fixnum bb-width) 
(sequent iai 

(decr-wrap-s-offset) 
(paral lel-wi th-s-access 
bb-9-of fset 

(assign byte-s (1- bb-uidth)) 
(assign byte-r bb-uidth) 

(assign bb-s-uord (Jogxor bb-constant (Idb memory-data byte-s bute-r)))) 
assign byte-r (- (a-constant 32.) bb-uidth)) ^ ^ 

(paral iel 

(ass ign-vwa-of fset d) 
(lisp (trace-path ti/2)) 

(iump bb-byte-a I u-opcrat ion-dispatch))) rjcail 
(paral lel-wi th-return * ^ 

„_( I isp( trace-path U/l))})) 

(defucode ubi tbI t-d-al igned-row-both-backuards ;13 cycles per word 
(paral Iel ;1 cycle 

(assign bb-width (- bb-width (a-constant 22.))) 

(trap-if fmlnus-f iKnura obus) ubi tbi t-d-a I i gned-row-bo th-backwards-done) ) 
(decr-wrap-s-offset) ;! cycles 

(paral Iel -w(th-s-acces5 ;3 cucle3 

bb-s-offset 

Mssign byte-s (31- bb-s-bi tpos) ) 

iassign byte-r (32- bo-s-bi tpos) ) 

fasslon bb-s-uorc2 (foaxor bb-constant ■emory-data) ) ) 
(ass ion bb-s-word (idb b6-s-word2 byte-« byte-r bb-s-uord)) :1 cucie 
^P?:a^!«' ,, , ,, ;U3 cycles ' y « 

(assign-vBia-offset d) 
^ (call bb-uord-aiu-cperotion-dispatch)) 
(decr-d^offset) •! 

(parallel 

(assign bb-s-word (rotate bb-s-word2 bute-r)) •! 

(I isp (trace-path ff/,)) 

(jump ubi tbI t-d-a I igned-rcu-both-backwarda) ) ) 

(defucode ubi tbI t-d-al igned-row-both-backwards-dono 
(trap-no-save) 
(if (plus-fixnum bb-width) 

(if (grcater-or-tqual-f ixnuB bb-s-bitpos bb-width) 
(sequent iaI 

(assign byte-r bb-width) 

(assign bo-s-word (rotate bb-s-word bute-r)) 

(assign byte-s (1- bb-widthii 

(assign byte-r (- (a-constcnt 32.) bb-width)) 

(paral Iel 

(assian-vma-of f set dl 
(I isp'(trace-path U/'-)) 

(jump bb-byte-alu-operation-dispatch))) ; jcal I 
(sequential ^ 

(occr-wrap-s-offset) 
(paral lei-ui th-s-access 
bb-s-offset 
(assign byte-r bb-width) 
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(assign bb-s-uord Crotate bb-s-uord byte-r)) 

(assign bb-5-uord2 (logxor bb-constant memory-data))) 
(para) iel 

(assign byte-r (- bb-width bb-a-bi tpos) ) 

(assign a-teffp obus)) 
(assign byte-s (1- a-teirp) ) 

(assign bb-s-word ( I db bb-s-uiord2 byte-s byte-p bb-s-uord)) 
(assign byte-s (1- bb-width)) 
(assign byte-r (- (a-constant 32.) bb-uidth)) 
(parallel 

(assign-vma-of f set d) 

(I isp (trace-path tt/S)) 

(jump bb-byte-a I u-operat ion-dispatch)))) • jcal I 
(para! lel-ui th-retum 

(I isp (trace-path ti/2))))) 



;;code for Xdecode-bi tbi t-arrays 

••Take alu from-array to-array 

;;Retupn (s-beg-addr s-beg-bitpos s-rou- length s-heiaht s-bi ts-per-ef t 

;; d-beg-addr d-beg-bi tpos d-pow- (eng th d-height d-bi ts-pep-el t 

; : «ppay-reg-«vent-count} 

;;args 

(defatomicpo bbd-atu (anem (stack-pointer -2))) 

(detatoffiicro bbd-s-array (amem (stack-pointer -1))) 

(defatomicro bbd-d-arp3y top-of-stack-a) 



2))) 



5))) 

6))) 

7))) 

8))) 

9.))) 

IG.))) 

11.))) 

12.))) 

13.))) 

14,)}) 




(defatomicpo 
(defatomicro 
(def stomicro 
(defatonicro 
(defatomicro 
(defatomicro 
(defatomicro 
(defatomicro 
(defatomicro 
(defatOBiicro 
(defatomi cro 



bbd- 
bbd- 
bbd- 
bbd- 
bbd- 
bbd- 
bbd- 
bbd- 
bbd- 
btd- 
bbd- 



•s-beg-addr 
■s-beg-bi tpos 
■s-roui- f ength 
s-height 
s-bi ts-per-el t 

d-beg-bf tpos 

d-rou~length 

d-height 

d-bi ts-per-eJ t 

event-count 



(amem 

(amem 
(amen 
(amem 
(amem 
(amem 
(amem 
(amem 
(amem 
(a!ses 
(amen 



(stack 
(stack 
(stack 
(stack 
(stack 
(stack 
(stack- 
(stack' 
(stack 
(stack 
(stack 



-pointer 
-pointer 
pointer 
-pointer 
•pointer 
■pointer 
■pointer 
■pointer 
pointer 
pointer 



-pointer 15. ) ) ) 



(defatomicro bb-alu-depends-on- source 

(b-constant ^. (loop for alu 



( 5 10. 
:3 12. 
:0 15 



: source 
;dest 
jnei ther 



2 4 6 7 8. 9. 11. 13. 14. 



) 



;both 



8un (ash 1 alu)))) 

(defmicro compute-beg-bi tpos (for-what) 
(let ((beg-bitpos iselectq for-uhat 

(s ' bbd-s-beg-b i tpos) 
(d 'bbd-d-beg-bi tpos) 

(otherwise (ferror "Uhat is ^S" for-what)))) 
irou-length (selectq for-uhat 

(s *bbd-s-rou-)cngth) 
(d 'bbd-d-rou-length) 
., ,. , (otherwise (terror -Uhat is *S" for-what))))) 
(sequent tal 

(assign b- low-di vidend top-of-stack) 
(assign a-posi tive-di visor bbd-width) 
(parallel 

(assign b-high-dt vidend (a-constant 8)) 
(assign a-di vide-stEp-count (b-constant 15.))) 
iparal Iel 

(assign a-negat i ve-di vi sor (- a-posi t ive-divi sop) ) 
(call divide-subroutine)) 
;; bits per elt setup correctly in byte-r 

(assign , beg-bitpos (set-type Tpotate b-hiqh-di vidend bute-p) dtp-fix)) 
assign b-temp (set-type (Tdb ,Pow-length 27. 5 0) dtp-fix)) 
iassicn a-temp b-tempj 
(mpy-22-32 a-temp b- lou-di vidend set-b-temp for-effcct nil)))) 

(defmicro set-b-temp (x) 
• (ass ign b-temp ,x) ) 

(defuccde ubi tbi t-decodeTarrays 
;;see whether the alu operation depends on the source arrau 
assicn oute-r (32- bod-alu)) ^ 

(if (Tdt:»-bi t-test bb-a tu-depends-on-scurce bute-r) 
(sequential 

tassign top-of-stack (b-constant 6)) ; the "subscript" 
(para t Iel 

(chcck-arg-tyoe array bbd-s-array dtp-array) 
(assign vma bt'd-s-array) 
(assign b-vma bfcd-s-array) 
(cal I arrai|-setup-2d)) 
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(parallel (assign b-ter.p bbd-contpol) 

(assion bbd-event-count bbd-control) 
(cal Tbbd-bi ts-per-ei t)) 
(parallel (assign bbd-s-bi ts-per-e I t b-temp) 

(assian byte-r b-te.rp)) 
assinn bbd-s-rou- I enqth (rotate bbd-width byta-r)) 
tccnpute-beg-bi tpos s) 

jGtiSinn bb'j-5-beg-ad:ir {+ bbd-base-potnter b-te::p) ) 
(acs.gn bba-s-heinht tbd-nein^t)) 
tacsign c*:d-evont-c6unt array-rcg i ster-event-count) ) 
iztzi-.-, tcp-ci-stock (b-constant 0)) 
iparci lei 

jcnec.-ar r:-ti;-e arra.j bbd-d-arrau dtp-array) 
(acBinn vra bbd-d-srrau) 
UECtrin b-vrra bbd-d-arra'^) 
(C3! I array-setup-2d) ) 



;assunitnc| event count 13 low 23. bits 
tan event happened, go retry 



(assign bbd-event-count (Idb bbd-event-count 28. 0)) 
(assign b-tetrp obus)) ^ ;«ove to b side 

(if (not-enua I -pointer b-terp bbd-control) 
(goto ubi tbl t-decode-arrays) 
(drop-through)) 
(parallel (assign b-temp bbd-controt) 

(call bbd-bi.ts-per-el t) ) 
(parallel (assign bbd-d-bi ts-per-el t b-temp) 

(assign byte-r b-tenp)) 
(assign bbd-d-rou- length (rotate bbd-width byte-r) J 
(compute-beg-bi tpos d) . x, 

(assign bbd-d-becj-addr (+ bbd-base-pomter b-temp)) 
(assign bbd-d-heic!ht bbd-height) 
;;weiT, 1 guess we'd better not get pcisr d here, 
(parallel Tassign xbas (+ stack-nointer (b-constant 5))) 

(assign b-teirp-2 obus)) 
(assign stack-pointer (+ stack-pointer (b-constant -3))) 
(parallel 

(assign b-temp (b-constant 11.)) 
(JUMP bbd-f inish-loop) ) ) 

(defucode bbd-f inish-loop 
(para I lei 

(assign b-temp (1- b-tenp)) 

(if (minus-f ixnua obus) (return) (drop- through) )) 
(pushval (set-type (ansK (xbas-d)) dtp-fix)) 
iparal lei 

(assign b-teinp-2 (1+ b-temp-2)) 

(assign xbas obus) 

(juBp bbd-f inish-loop)) ) 

;;take an array-register control uord in top-of-stack, return a decoding of its 
:;dispatch type in top-of-stacK, 

(defucode bbd-bi ts-pcr-el t 

(dispatch-after -this (array-register-dispatch-field b-temp) 
(noD) 

((Xarray-register-dispatch-l-bi t) ^^ . .. , 

(parallel (assign t-temp (set-type (b-constant 0) dtp-ftx)) (return))) 

( (Xarray-regi ster-di spatch-2-bi t) _ ^ . . , , 

(oaraTlel (assign b-teirp (set-tijpe (b-constant 1) dtp-ftx)) (return))) 

((larray-register-disp3tch-4-bt t) ^^ ,^ ^ 

(parallel (assign b-temp (set-type (b-constant 2) dtp-fix)) (return))) 

((Xarray-register-dispatch-S-bi t) ^ ^^ , 

(parallel (assign b-temp (set-tupe (b-constant 3) dtp-fix)) (return)); 
( {*arrc;u-register-di spatchi-lS-bi t) 

(parallel (assign b-temp (set-type (b-constant 4) dtp-fix)) (return))) 
( (*arrau-regt ster-di spatch-uord) 

(parallel (assion b-tetr.p (set-tups (b-constant 5) dtp-fix)) (return))) 
(otneruise (sjgnaT-error unirnpleniinted-or-i t legal -array- type) ) ) ) 

;;; -»- ModeiLisp; Packaneillicro; Gase:3; Louerceceiyes -*- 
;;; (c) Copyright iS£2, Syisbotics, Inc. 

;;;; BITBLT wicrocode for 3603 



• Reads can be repeated with no harmful effects, writes cannot be (in most cases). 
; State is not permanently updated until a write is consummated. 

; After every write, state should be updated so that if the next memory operation 

; faults and pclsrs, that write will not be repeated (the bitblt row will be shorter), 

• to avoid the overhead of doing this for every write, we have block node 
: operations that only update the state after writing a block of words. 

; For the block node things, we use a buffer that can be saved. See next+1 page. 

; For the short-row things, when the destination is epiit across two words, 

; we check write access to both words before modifying either of thea. 

; No pclsring problems if the operation depends on neither operand. 

; Uhen there is a partial word at the front, do it and then advance the arguments 

: so the bitblt is word a/jgned in the destination. Uhen there is a partial word 

: at the end. uhen we get there the arguments have been advanced. 

(reserve-scratchpad-memory 2463 2470 220 333) 
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(defffllcro wai ting-for-»emory t documentation only, 

• (nop) ) 

(defRiicro abus-array-data (&bodu body) 
•(parallel 

(transport data) 

(check-data-type (nemory-data dtp-fix) 

••body) ) 

(dcfmicpo assign-vma-of fset (which drest stuff) 
(selectq which 

(S • (assign vma (+ bb-s-rou-addr fcb-s-offset .•stuff))) 
(0 Mass ion vtr.a (+ bb-d-rou-addr bb-d-offset ,»stuff)}) 
(S-ahead (assign vnia (+ bb-s-row-adcr bb-s-of fset-ahead ,«stuff))) 
(otherwi se 
(ferror "ass i gn-vma-of feet knows about only S and D, not *S" Mhich)))) 

(defmicro paralle!-wi th-s-access (offset 4bodu body) 

(ffiake-Btc3iory-acces3 'bb-s-row-addr 'bb-s-offset offset body Mread))) 

(defmicro paral le !-wi th-d-access (offset &body body) 

(make-mcmory-3cces9 'bb-d-row-addr 'bb-d-offset offset body Mread))) 

(defmicro paral lel-ui th-d-access-check-nr t te (offset fibody body) 

(make-Biemory-access 'bb-d-row-addr 'bb-d-offsot offset body ^(read write))) 

(evai-when (eval compile toad) 

(defun make-memory-access (baseaddr offset-»ym offset body »e«oru-»odes} 
(or (eq offset offset-sum) 

(equal offset * (1-t- '.offaet-sum)) 

(and (eq offset-sym * tb-s-of f set) (oq offset 'bb-s-of fset-ahead) )■ 
(ferror "^S is not a recognized offset for -.^S" offset offset-sum)) 
(let* ((body (reverse body)) 

(finally * (abus-array-data » (car body)))) 
(do ((II (reverse 

'((assign vma ,(if (atom offset) 

'(+ .baceaddr .offset) 
•(+ .baseaddr .(second offset) 1))) 
(start -memory .•memoru-modes) 
(wai t ing- for -memory) ) f 
(cdr ID) 
(body (cdr body) (cdr body)) 

((ond (nu! I II) (r.ul I body)) 
(secuc-ntiat .•! .f inoi lu)) 
(cond ((null tl) (pu=h (car'boog) I)) 
Jinul 1 body) (push (car ll) I)) 
i.rwa; K * ^^"^^^ ^parallel .(car II) .(car body)) I)))))) 



'/;:::! ;^*'-*.I^ec'2 are *not* analogous to 1- 
lce-~:cro o^- (operand) , ,._ 

'(- <b-con«tant 32.) .operand)) 
(defaicro 31- (operand) 

M- lb-constant 31.) .operand)) 

Cdefaicro incr-d-of fset 

'(assign bb-d-offset (1+ bb-d-of fset) ) ) 

(def»icro decr-d-of fset 

•(assign bb-d-offset (1- bb-d-offset) ) ) 

(defaicro incr-wrap-s-of f set 
' (sequent iai 
(paral lei 

(assign bb-o-offeet (1+ bb-s-of fset) ) 
(assign b-temp-3 obus)) 
(if (greater-or-equal-f ixnura b-tetr.p-3 bb-s-row- length) 
(paral iei 

(lisp (foraat T "**»>Hrapping around on bb-s-offset from ^d. 

(lou32 (tr ^bb-s-offset)))) 
(assign bb-s-offset (b-constant fi))) 
(drop-through)))) 

(defaicro decr-wrap-s-of fset 
'(paral lei 

(assign bb-s-offset (1- bb-s-offset)) 
(if (ainus-f ixnua obus) 
(paral lei 

(lisp (format t •*^»>Decr wrapping around on bb-s-offset")) 
(assign bb-s-offset (1- bb-s-row-length)) ) 
(drop-through)))) ^ 

(defaicro- incr-wrap-s-off set-ahead 
' (sequent iaI 
(paral lei 

(assign bb-s-of fset-ahead (1+ bb-s-offset)) 

(assian b-tetno-3 obus)) 
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parat ieM 



(if (greater-or-equ3l-f iKnua b-temp-3 frtt-s-row- length) 
(para I )e) 

(lisp (format T "*^»>Ur2Dping around, on bb-s-offset fro« ^^d. 

{low32 (tp *t:b-s-off set-ahead)})) 
(assign bb-s-off set-ahead (b-constant fi) ) ) 
(drop-through) ) ) ) 

(def micro decr-wrap-s-off set-ahead 
'{para I lei 

(assign bb-s-of fsct-ahead (1- bb-s-offset)) 
(if (mi nus-f ixnum obus) 
(parol lei 

(lisp (format t •'^>>>Oecr wrapping around on bb-s-offset")) 
(assign bb-s-of f set-ahead (1- bb-s-rou-iength) ) ) 
(drop-through)) ) ) 

(dcfmicro store-word (datura 4rest options) 

'(•tore-contents (set-type , datum dtp-fix) not-pointer . , options)) 

—-the goddamn simulator compiles 

(parallel (assign ...) (return)) 
into 

(prog ... (return nil) (setq ..,)) 
(defmicro paral lef-ui th-return (^body stn) 

M,(if (eq «ffiachi ne-ver si on* *8im) * sequential * 
• •stm 
(ret urn) )) 

(defvar «fp-off set-names* ()) 

(defmacro def-fp-of f sets (Arest names) 
(loop for i upfrorn 8 

for name in nanes 

append * ( (defatomicro .name (crfietn (frame-pointer ,i))) 
(defprop .name ,i fp-offset) 
(or (memq *,nan-,e »fp-Qf feet-names*) 
(push *,name «fp-off set-names-*) ) ) 
into foo 
finally (return Mprogn 'compile ,#foo)))) 

;:decode fp offset numbers into symbols. Debugging only, 
(defun dfp (&rest numbers) 
(loop for numoer in numbers 

collect (loop for name in *fp-of fset-names* 

when* (equal (get name 'fp-offset) number) 

return name 

finaUy (return number)})) 

;; Define arguments/state for BITBLT instructions. Note that thes3 must be 
;; relative to FP, not to the top of the stack, since there might be a 
:: saved bi tbi t-buf fer on the stcck if the instruction uas interrupted. 
(def-fp-of f sets 

bb-arg-alu bb-arg-width bb-arg-hei ght t I i 8p arg 
bb-arg-from-array bb-arg-from-x bb-arg-fro»-y ; M sp arg 



bo-arci-to-arroy bb-arg-to-x bb-arg-to-y 

bb-uiath 

bb-8-data-cddr 

bb-s-row-of fset 

bb-s-offset 

bb-s-fci tpos 

bb-s-rou- length 

bb-d-data-addr 

bb-d-offset 

bb-d-bi tpos 

bb-event-count 

bb-a)u-operatton 

;;; Some temporaries. 

(def ine-b-temps bb-constant 
bb-s-word 
bb-s-row-addr 
bb-d-row-acdr 
bb-uidth-b 
b-block-size) 

(defareg bb-constant-a) 
(defareg bb-identitu) 
(defareg bb-s-word2) 
(defareg t-o-a-temp) 
(defa'"eg bb-s-of f set-ahead) 
(defareg a-block-size) 
;;; Bi tbI t-buf fer hair 

(eval-uhen (compile load cval) 
(defconst n-bi tbI t-buf fers S) ) 

*. Mprogn 'corpi le^ :B-memcry buffer for bIccK-mode operations 

. .(loop for ) from below n-bi tb I t-buf fers wpcraxiona 

collect '(defbreg ,(f intern "BITBLT-BLFFER-^" i)))) 



; t icp arg 

;ucode arg 

;ucode arg 

;ucode arg 

;ucode arg 

;ucode arg 

•ucode arg 

;ucoda arg 

; ucode arg 

; ucode arg 

; ucode arg 

; ucode arg 



;Vaiue to store or to XOR in 

; temp (source word) 

: start of current source row 

; start of current destination row 

:copy of width on B side (sometimes) 

tnuraoer of words in block 

;A-side copy of bb-constant 

;Background to dpb into when doing part word 

; temp (other source word) 

;s-offset not finalized yet (if pclsr) 
; number of words in block 
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(defmlcro b i tbl t-buf f er (i) 

(fintern "BITBLT-BUrF£R-^D" i)) 

:^!^*-ir^^ conpute the result n words at a time into the bi tbl t-buf fer, 
jand-then store . t rnto the destination {in one case the uhole buffer 
:is rotated by 1 to 31 bits as it is being stored). ouTter 

;lhe b» tbl t-buf fer ts "active" while us are storina it into thn ri*«+ina+;«^ 
:The bitbit buffer must be active while wo are «iS?fyinrthe d^^inalio^ 
;s,nce the words copied into the buffer might overlapped with par {90° 
xtht destination we have already oo;iified« «hm=u wnn parxs or 

~ St ?l n««'?n%"*'"9 ^^'* buffer and its .ave/restore nechanysSf 
. St.M neeo to fix Oicrocoop. (er to default cdr source froa Bbus correctly -— 

;CaM here if we pctsr with the bi tbl t-buf fer active 
(defucode save-bi tbl t-buf fer -witve 

^. Mseguent ial . 

•(loop for i from below n-bi tbl t-buf fers 
t^ . ^. collect '(pushval-wi th-cdr (bi tbl t-buf fer . i ))) ) 
asston first-part-done (b-constant D) o^^Tcr ,uin 
(paraT lei 

(assign bitblt-buffer-active (b-constant 0)) 
ire turn) ) } 

iitll ^fe "t^s" afoutto etart storing the bi tbl t-buf fer 

ijell 'cUnnr,ll,^-XTHt llilT ''' ''''' instruction of the routine 

(defmicro act(vate-bl tbl t-buffer {) 
•(parallel 

(assign bi tbl t-buf fer-active obus) 

^'''■" ic;I;^?|IsI;iS!b?ib'?I^^^?fi?r)?"'''"' (byte-.a,K firet-part-^one))) 

;Ue also need this closed-subroutine version 
(defucode act i vate-bi tb I t-buf fer 
(parai lei 

(act i vate-bi tbl t-buf fer) 

(return) ) ) 

(defucode act i vate-saved-b i tb I t-buf fer 
(parai tel 

#.* (sequent ial sRetry the assign, trap-i f upon return 

••(loop for i from (1- n-bi tbl t-buf fere) downto 
col lect (parai lei 

(assign (bi tbl t-buf fer J) top-of-stack-a) 
(para I le I tdecrement-stack-pointer ) ) ) ) ) 

(assign first-part-done (b-constant 01) 
(return) ) ) 

;Call here when done storing the bi tbl t-buf fer 
(defucode deacti vate-bi tbl t-buf fer 
(parai !el 

(assign bi tbl t-buf fcr-act ive (b-constsnt 0)) 

.,(^et:M^"°^- ^^^ ^^ top-of- stack-a) jCould have been bashed by activate... 

(defmicro read-bb-»-word 
Mparal lei 

id;JScSde%aS!bS-:-5SrSl " ''*" """"'* "•'^*'^* *" "i' e °* the first .ord 

(assicn-vna-of f set s) 
(parallel 

(assign byte-r (32- bt?-»-bi tpos) > 
(ctart-memory read)) 
(parai tel 

(war t ing-for-memory) 

(if (lesser-or-egual-f ixnum a-temp (b-constant 2'^ )) 
:; source ! 5 entirely within one word 
(parai lel-ui th-return 
(abus-array-data 

;;sour§r?; spIft"acroil°?::r.Srdr"'''"* '^'^^^^ .-ory-data byte-r))))) 

(sequential 

(abus-array-data 

(assign bb-s-word (rotate aemory-data byte-r))) 
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Oncr-urap-s-cff set -ahead) 
(asaicn-vma-of fset s-ahead) 
(parai id 

(start-metrory read) ;bijte-r is already ok 

(parol lei 

(uai t ing-for-merrory) 
(assign tDyte-9 (i- a-tercp))} 
(obus-arrau-data 

(assign fcD-5-word (dpb ■emory-data byte-a byte-r bb-s-uord))) 
(para I le !-uii th-return 

(assign bb-8-uopd_ ( l ogxor bb-g-uord bb-cc nstant-a) )))))) 

Assumptions about •etup: 
bb-constant has: 

>> for constant operations (8,-1): the constant; 

» for operations dependent only on source or destination (x, **.x. u. ^\j) t 

a for x,y or -1 for ^x^'.^i t • y. ^ 

» for operations dependent on both s and d: 9 for those using source directly 
•nd -1 for those that want the source coaplenented, 

(defucode bb-copy-stuf f-to-b-eide 

(assiqn bb-s-rou-addr (+ bb-s-data-addr b-temp)) 
(paral ie(-with-return 

(assign bb-d-rou-addr bb-d-data-addr) ) ) 

(def macro def inst-bi tbi t (name source destination neither both) 
•(definst .name no-operand 

(paral iel (assign b-temp bb-s-row-of fsot) 
(call bb-copy-8tuff-to-b-s)deU 
(dtspatch-after-this (parallel (Idb bb-alu-operation 4 B) 

;; Set up corstant needed for the most common case 
(assign bb-constant (via-xtjs (b-constant 6))) 
(assign bb-constant-a (via-xbus (b-constant Q)))) 
(assign bb-width-b bb-uidth) 

((c) ;0 

(goto ,nei ther)) 
id) Txsty 

(parallel (assign bb-identity (a-constant -1) ) 
(jump .both))) 

(assign bb-tdentity (a-constant -1)) 

(parallel (assign bb-cpnstant (a-constant -1)) (assign bb-constant-a (a-constant -D) 
( jump ,both/ } } 
((3) (return)} ;y 

((4) tx«^y 

(parallel (assign bb-*identity (a-constant -1)) 
(jump .both))) 
((5), (goto .source)) -x 
((b) ;x xor y 

(parallel (assign bb-identity (a-constant 0)) 
( jump .both) ) ) 
((7) ' "^ ;,c+y 

(parallel (assign bb-identity (a-constant 9)) 
(jump .both))) 
( Jo. ) ;*.x»-*y 

(assian bb-identity (a-constant -D) 
(parallel (assign bb-cpnstant (a-constant -D) (assign bb-constant-a (a-constant -D) 

( (3» ) ;-x xor y 

(assian bb-identity (a-constant 0)) 

(parallel (assign bb-cpnstant ia-constant -1>) (assign bb-constant-a (a-constant -D) 
, ,,^ , I jump .both) ) J 
((10.) ;^x 

(parallel {?»«'9"^^^;^^J^>|a"* (a-constant -D) (assign bb-constant-a (a-constant -D) 

((11.) ;'^x+y 

(assign bb-identity (a-constant 0)) 

(parallel (assign bb-cpnstant (a-constant -IJ) (assign bb-constant-a (a-constant -D) 
,,,_ . ijump ,Doth)>} 

( (ZZ* I ;mj 

(parallel (assign bb-constant (a-constant -1) ) (assign bb-constant-a (a-constant -D) 
t jump .dest mat ion) ) ) 
iy^'f ^x+^^y actually, *(*^x«y) 

(assiqn bb-identity (a-constant -1)) 

(parallel (assign bb-cpnstant (a-constant -D) (assign bb-constant-a (a-constant -D) 
I jump .bothi J > 
^]l**-j ;*'x+^ actually, *(xKcy) 

(parallel (assign bb-identity (a-constant -1)) 
//ic X ^J"'"^ .t>oth))) 

\ tlb, ) y-l 

(parallel (assign bb-constant (a-constant -1) ) (assign bb-constant-a (a-constant -1)) 
\ J uiBp f ne I tner )>)))) 

(def inst-bi tbi t tbi tbi t-short-row 
ub i tb I t-shor t-row-source 
ub i tb I t-shor t-rou-des t i na t i on 
ub I tb I t-shor t-r ou-ne i ther 
ubttblt-short-row-both) 
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^^s^i'^st-bitblt tb;tbtt.long-roy 
ub J tb 1 1- i ong-r oui-so jrce 
."k - !5 1 1" ! °^9-^0"-de3 1 i nat i on 

k'!? !" °'^3-rcN-neither 
ub) tbi t-long-row-bothi 

ub ; b t- onn-rou.source-backwards 

S ' Ik !* ong-row-dest i nat i on 
UD I tb I t- long-row-nei thpr -i* 

ubitblt.iong-row-both^backward5) _ jdirect.on tmmater.a! 
(defucode ubi tbI t-short-pou-source 
(pead-bb-s-uord) 

(assiqn a-tenp (+ bb-uidth-b bb-d-bi tpos) ) 
(parallel 

Jassian byte-s (- a-temp (b-constant 22.) 1)) 
(if (iesser-or-equal-f (xnun-unsiqned a-temp (b-conatant 32 )) 
;; destination is entirety wTthfn one word 
(paral te l-wi th-d-acccrs bb-d-cf fset 
(assign byte-s (1- bb-width)j 
(assign bute-r bb-d-bitpo&) 
(papaliel-ui th-return 

(store-uord (dpb bb-s-uord byte-s byte-p wemoru-data) ) ) ) 
;; destination is rp t i t across two words 
;; «ust access-check thcss botn before Bodifying either 
t sequent i a I 
:; compute the hioh byte 

(paral lel-uith-d-acces5-checK-wpite (1+ bb-d-offset) 

(assign byte-r bb-d-bitpos) 

(assign a-temp (idb bb-s-uord byte-s byte-r neraoru-data) ) ) 
;; compute and store the leu byte ^ aaia^M 

(paral lel-ui th-d-acces* bb-d-of f set 

(assign byte-s (31- bb-d-bl tpos) ) 

(fitore-word (dpb bb-9-word byte-s byte-r iicnjory-data) block)) 
;;."??. *}°^?.^^* ^*S^ ^y^«' This cannot fault ^ oiockiJ 
(psral lel-ui th-retupn 

(stope-uord a-temp block)))))) 

(defucode ubi tbI t-short-row-deet inat ion 
(assign a-temp (+ bb-w idth-b bb-d-fc i toos)) 
(parat lei 

(assiqn byte-s (- a-temp (b-constant 32o ) D) 
((f (lesser-or-equat-f ixnum-unsiqned a-temp (b-constant 2''.)) 
;; destination is entirely within one word 
(paral lel-wf th-d-access tb-d-offset 
(assign byte-s (1- bb-uidth)) 
(asstqn byte-r bb-d-bitpos) 
(paral lei -wi th-return 

(store-word (logxor (dpb tb-constant byte-s byte-r 8) ■emoru-dsta) n > 
;; destination is split across two words "emory a«tanjj 

Uequlntia"'*''"''^''*'*' *^*" ^°^*^ ^®^°'"* rodifying either 
;; compute the high byte 

(paral iei-ui th-d-access bb-d-of fset 
(assign byte-s (31- bb-d-bi tpos) 1 
(assign byte-r bb-d-bitposi 

; : '^r ItS^%^^l°gT,°; iX^''^^^:^)^:^^'''-' '' .e.oru-data, MocK), 

iparal let-wi th-re turn 

(store-word a-temp block)) )))) 

;; The alu operation is actual ly a constant ^ 
(defucoce ubi tbI t-short-row-nei ther 

(assiqn a-temp (+ bb-width-b bb-d-bitpos)) 
(if (Tesser-or-equal-f ixnuffl a-temp (b-constant 32.)) 
;; destination is entirety within one word 
(paral i el -wi th-d-access bb-d-of fset 
(assign byte-s (1- bb-width)) 
(assiqn byte-r bb-d-bitpos) 
(paral lei-wi th-return 

(store-word (dpb bb-constant byte-s byte-r memory-data)))) 
;; destination is split across two words, but no pciirr problems since doing 
;; the operation twice produces the same effect 
(sequent tal 

;; store the iow byte 
(paral iel-wi th-d-access bb-d-of fset 
(assign byte-s (31- bb-d-bitpos)) 
(assign byte-r bb-d-bitpos) 

(store-word (dpb bb-constant byte-s byte-r memory-data))) 
:; store the hiah byte 
(parat Iel-wi th-d-access (1+ bb-d-of fset) 
(assign byte-s (1- »-temp)) 
(assign byte-r (a-constant 6)) 
(paral lel-uith-return 

(store-word (dpb bb-constant byte-s byte-r MBory-data) ) ) ) ) ) ) 
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:; The alu operation depends upon both source and destination bits 
(defucode ubi tbi t-short-row-both 
lrc2d-bb-s-word} 

(aesinn a-teirp (+ bb-utdth-b bb-d-bi tpos) ) 
(if (Tesser-or-equai-f ixnum a-tcmp (b-constant 32.)) 
:; destination is entirely within one word 
(sequential 

(assign byte-s (1- bb-width)) 
(assign byte-r bb-d-bi tpos) 
(parallel 

(assign-vBia-of fset d) 

(jump bb-byte-alu-operation-dtspatch) )) ; jcal I 
;; destination is split across tuo words 
(sequential 
;; make sure we have write access to the high byte so no pclsr after ctoring 
(assign-vma-of fset d 1) 
(start-aemory read write) 
;; store the tow byte 
(assign byte-s (31- bb-d-bi tpos) ) 
(assign byte-r bb-d-bitpos) 
(parallel 

(assign-vma-of f set d) 
(cai I bb-byte-alu-operation-dispatch) ) 
;; store the high byte 

(assign bb-s-word (rotate bb-s-word byte-r)) 
(assign byte-s (1- a-temp)) 
(assign byte-r (b-constant 8)) 
(parallel 

(assign-vma-of fset d 1) 

(jump bb-byte-alu-opera_t|on-dispatch)) ))) : JcaM 

(booie fn X y . 7.1" i f fn is "abed" then 

yB 1 2 3 4 B S 7 

I 9 1 K*y wx»y y x*-y x x^y x+y 
.... 



X 

1 



a c S 3 10 11 12 13 U 15 

I* (x+y) •(x)i^y) •x *x+y ^y x+-^y •^x+'^y -1 
b d 



;v»a and byte reos have been set up already, for DFB. 
.; trashes a-tetnp-2, b-teRp-2, b-teffip-3, but not a-teoip and b-temp. 
(defucode bb-oyte-atu-operat'ton-dispatch 

(dispatch-af ter-this (parallel (start-memory read) (lob bb-alu-operation 4 0)) 
(para( }ei 

(assvcin b-te.tp-3 (dpti bb-s-word byte-s byte-r bb-idsnt i ty) ) 
(ua'i t'tng-f or-rnefflory) ) 
((12) ;;1 x«y logand ;;2 -x*y logand 
(para! lel-wi th-return 
(paral lei 

(dec lare-memory-t iaing data-cycle) 
(abus-array-data * 

(store-tjord i 1 ogand wemory-data b-temp-3) ) ) ) ) ) 
((4 8.) ;;4 'vi^x+y) ■ xi*>-y andc2 ;;8 •'(x+y) « -^xsmj andcb 
(paral lei 

(dec I are-memory- 1 i » i ng data-cyc I c) 
(abus-array-dota 

(assign a-temp-2 memory-data))) 



(assign b-temp-2 (dpb (b-const3nt -1) byte-s byte-r 0)) :can*t merge this..* 
(assign a-ten:p-2 (logxor a-terap-2 b-teap-2)) ;,.,with this. 

(paraT lel-wi th-return 



(store-word (logand a-temp-2 b-temp-3)))) 
((B 9.) ;;B x//y logxor ;;9 '^ ixffy) m^xtfy logxor 
(paral lel-wi th-return 
(parallel 

(dec I are-memory-timing data-cycle) 
(abus-array-data 

(store-word (logxor b-temp-3 memory-data)))))) 
((7 11.) ;;7 x+y logior ;;11 •'X+y logior 
(paral (e!-wi th-return 
(paral let 

(d£Clare-memory-t iming data-cycle) 
(abus-arr ay-data 

(store-word (logior b-temp-3 memory-data)))))) 
((13. 14.) ;;13 x+^y « *'('^x«y) lo^nand ;;14 'vx+*^y«A*(x*y) 
(paral lei 

(deciare-memory-t tming data-cycle) 
(abus-arr ay-data 

(assign a-temp-2 (logand b-teTRp-3 memory-data)))) 
(paral lel-wi th-return 

(store-word (logxor (dpb (b-constant -1) byte-o byte-r 0) a-tcrap-2)) ) ) ) ) 
;*v«8 has been set up already 

(defucode bo-word-alu-operat ten-di spatch tcommonly 3 cycles (plus 1 for the call) 
(dispatch-af ter-this (parallel (start-memory read) (Ido bb-alu-operation 4 0)) 

(wai t ing-for-mecory) t want to use this somehow... 

((1 2) ;;1 x«cy togand ;;2 '•^xsty torjand 

(parallel 

tdec i are-memory- 1 i » i ng data-cyc I e) 

(abus-array-data (store-word (logand bb-s-word memory-data))) 
(return))) 
((4 8.) ;;4 k*^ andcb :;8 -^(x+y) ^x^t-vy andcb 
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iparai iel . . ^ . , % 

ideclare-mentory-timing data-cue I e) ^ ^ ^^^ 

(abus-array-data (store-word landc2 bb-8-word nemory-data) ) J 

(return) ) ) « / « ^ *^ i 

((6 9.) :;6 x)!fg iogxor ;;9 ^ixff\j)^xti^ logxor 

{paral let , , 

(declare-meoory-timing data-ctjcje) 

(abu*-array-data (store-word ilogxor bb-5-uord nenory-data) ) > 
(return) ) ) . * . . 

((7 11.) ;;7 x+y logior ;;11 *x+y logior 

(paral let 

(dec tare-meKory- timing data-cycle) . m 

(abue-array-data (store-word Tiogior bb-B-word ueuory-dataJ ) ) 
(return))) ^, , , 

((13. 14-) ;;13 x+-y - *(*x*y) ;;14 -x+-^— (x«y) 
(para I Iel 

(dec lare-»emory-ti wing data-cue I e) . ,,* 

(abus-array-data (store-word llognand bb-s-uord Bcmory-data) ) ) 
(return))))) 
::alu depends only on source bits 
(defucode ubi tbl t-tong-row-source 
(paral te I 

(assign b-teop bb-d-bitpos) 
(if (zero-f ixnuw bb-d-bitpos) 

(if (zero-fixnum bb-a-bitpos) 

(ooto ubi tbi t-ai iannd-row-source) 
•r SSSSSSSSSELcESSSSSSSSSSSSsssssss 

; ; dddddddddddddddddddddddddddddddd 
(para! leJ-wi th-s-access bb-s-of f sot 
(ass ion byte-r (32- bb-s-bi tpos) ) 
(parallel 

(assign bb-8-word2 (tooxor bb-constant (rotate ■emory-data bytE-r))) 
(lisp (trace-path )!^/c)) 
(iump ubi tbi t-d-al igned-row-source)) )) 
(if (equat-f ixnura b-temp bb-s-bi tpos) 

; ; S55SSSS3SSS5£SS§S3SSSSSSSsssssss 
; ; D03[)0D3DDO0D0D0DDDDODDiDDDddddddd 
(sequent iai 

(paral lel-wi th-8-3ccess bb-s-of feet 
(assign b-temp (32- tb-d-bi tpos) ) 
(assign byte-r b-temp) 

(assign bb-5-word (logxor bb-constant (rotate Menory-data byte-r)))) 
(paral le)-wi th-d-access bb-d-offset 
(assign byte-r bb-d-bitpos) 
(assign byte-s (1- b-terr.p)) 

(store-word (dpb bb-«-word byte-8 byte-r Bercory-data) ) ) 
;; First partial word dono, ue are now the aligned case 
( incr-wraprs-of f set) 
(incr-d-of fset> 

(assign bb-width (- bb-wldth b-temp)) 
(assign bb-s-bi tpos (b-constant C)) 
(parallel 

(assign bb-d-bitpos (b-constant B)) 
(lisp (trsce-path #/b) ) 
( iump ubi tbl t-al igned-row-source) ) ) 
(if ( lesser- f ixnum bb-s-bi toos b-temp) 

' ] SSSSSS8S6SS5S5S5SSS55SSSS 

DDDDDDODDDQODCODdddddddddddddddd 
•- 32-d,bi tpos -^ 
(sequent tat 

(para! le!-wi th-s-accress bb-s-of f set 
(assign byte-r (32- bb-s-bi tpos) ) 
(assign b-temp (32- bb-d-bitpos)) 
(assign bb-s-word doaxor bb-constant (rotate aeaoru-data byte-r)))) 

: : S5SSSSSSCSS3SS5SSSS5S5SSS 

(paral ie!-wi th-d-access bb-d-offset 
(assign byte-r bb-d-bitpos) 
(assign byte-s (1- b-temp)) 

(store-word (dpb bb-s-word byte-s byte-r ■emory-data))) 
;; First partial D word done, eoae S bits froa first word remain 
(incr-d-of fset) 
;; rotate s-word further to right by 32-d. bi tpos ■ left by - (32-d. bi tpos) 

; ; SSSSSSSS3SSSS3SS sssssssss 

(assign bb-s-word2 (rotate bb-s-word byte-r)) 
(assign bb-s-bi tpos (+ bb-s-bi tpos b-terrp)) 
(assign bb-wtdth (- bb-width b-temp)) 
(parallel 

(assign bb-d-bitpon (h-constant 0))) 
(1 isp (trace-path U/c)) 
i jurip ubi tbl t-d-al igned-row-source) ) 
(sequent la! 
;;The high part of the first source word is not as long as the high part of the 
;;first destination word. So extract the useful part of the first source word, 
:;and deposit into it ea much of the second source word as needed to fill out the rest 
;;of the first destination word. Then position the rest of the second source word 
;; appropriately for the inner foop. 

<-- 32-s — * 

|535555SSS5sssssssssssssssss8S£C3 

DDDDDDDDDDDDDDDD DXOODODODdddddd 
(pgral lel-wi th-s-access bb-s-of fset 
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(asstcn byte-r (32- bb-s-bi tpos) ) 

(assign b-tefr;p-2 bD-s-bitpos) ^ ^ ^ j. ^^^^ 

(assign bD-s-word (logxor bb-constant (rotate «eoory-data byte-p)))) 
-(incr-urap-s-off set-ahead) .i . w 

4 — 8-d ► *-- 32-8 — » (32-a)-l32-«J»s-a 

:: 69Ssssss3S25SSSsSSS£33SSSSSSSSSSllllllllin 

: : DDDDDDDDDODDDDDD DDDODOODDDdddddd 

'(paral lel-wi th-'s-access bb-s-of tcet-aheod 

(acsian byte-p (32- ob-s-bi tpos) ) 

(asoifin b!jtt:-8 (- o-tcmp-2 bb-d-bitpcs D) 

(a5£ion bD-9-uord2 (logKOP bb-constsnt •emory-data) ) ) 
(a3siGn''ijt:-s-word (dpb bD-s-uopd2 bytc-o byte-r bb-s-wopd)) 
(parr.Tlei 

(assign a-tcffp (32- tb-d-bi tpos) ) 

(acsign b-ter.p cbuc) ) 
(papal lel-ui th-d-access bb-d-offsot 

(assign byte-p fcb-d-bitpos) 

(assign byte-s il- a-tecip)) 

(stope-uord (dpb LL-s-nord byte-s byte-r wemory-datan ) 
;; Ue hav e now done the ftpst poptia! D wopd. Tupn into the_d-a I igned 
;; case, utth the tource advanced by one wopd fpo» whero it ttOPted. 
Vincp-d-of feet) 

(assign bb-s-offset bo-s-of feet-ahead) 
(assign bb-«-bitnos (- b-teinp-2 bb-d-bj tpos) ) 
(ass ion byte-r (32- bb-s-bi tpos) ) 
(assign bb-9-wopd2 (potate bb-s-worri2 byte-p)) 
(assign bb-width (- bb-width b-temp)) 
IpapaTtel ^ ^ ^^^ 

(assign bb-d-brtpos (b-constant ») ) 

(lisp (tpace-path tt/e)) ^^,,,,^, 

( jump ub i tb I t-d-a It gned-pou-toupce) )))))) ) 

(defucode ubi tbrt^^aTigned-rou-souPce t2S~cyc!es pcp 8 uopds 

(if (greater-op-equal-f ixnum bb-utdth (b-constant (* o, o^.iJJ 
::Fetch a block of wopds into the buffep 

"ass?on b-temn (+ bb-s-offset (b-constant 8.))) 
(if (lesser-f ixnun bb-s-pow- length b-temp) 

(goto ubi tbi t-al igned-pow-coupce-s Ion- loop) 
(sequential 
(papal (ei 

(assign-vma-of f set s) 
(ca/( ubi tbf t-block-pead-8)) 
(papaf tel 

(assign-vma-of fsct d) 
(call ubi tbI t-block-upi te-8)) 
(papal lei ... 

(assign bb-s-offset (+ bb-a-offset b-block-etze)) 
(Jump ubi tb! t-a! igned-pow-soupce) ) ) )) 
;:Frob uith what's left. Too bad dispatch blocks ape expensive, 
(if (greatep-op-equal-f ixnum bb-uiidth (b-constant (* 4 32.))) 
(sequent iai . 

(assign b-temp (+ bb-s-offset (b-constant 4))) 
(if (Tesser-f ixnum bb-s-pow-tength b-temp) 

(goto ubi tbt t-al igned-pow-soupce-slou-loop) 

(sequential 

- (papal lei 

(assign-vma-of fset s) 
(call ubitblt-block-pead-4)) 
(papal iel 

(assign-vma-of fset d) 
(call ubitblt-block-urtte-4)) 
(paraUel . ,, 

(assign bb-s-offset (+ bb-s-offset b-block-stze) ) 
( jump ub i tb I t-a I i gned-pow-soupce-s ! ou- I oop) ) ) ) ) 
(goto ubi tbi t-al igned-pou-soupce-slou-loop) ) ) ) 

(defucode ubi tbI t-al igned-pow-soupce-slou-loop ;10 cycles pep uopd 
(paral lel-wi th-s-acces9 bb-s-offset ;4 

(tpap-if (iesscr-f ixnum bb-uidth (b-constant 32.)) 
ubi tbi t-al igned-pou-source-s low- loop-done) 

(wai tina-fop-memopu) 

(assign''bb-s-wopd Tiogxop bo-constant fcemopy-data) ) ) 
(assign-vma-of fset d) •} 

(stope-uopd bb-s-uopd) Jj. 

(assign bb-width (- bb-width (b-constant 32.))) ;1 
(incr-wpap-s-of fset) ;2 

(papal Iel i^ 

(incp-d-of f set) 

(i isp (tpace-path tt/J) 

{ juap ub i tb 1 t-a I i gncd-pow-soupce-s 1 ow- 1 oop) ) ) 

;Do last partial wopd, if any 

(defucode ubi tbI t-a t igned-pow-soupce-s low- loop-dona 
(if (piup-fixnum bb-wtdth) 
(eequent iai 

(paral let-with-s-access bb-s-offsst 

(assign bb-s-word (logxor bb-constant »emory-data) ) ) 
(paral lei-ui tn-d-access bb-d-of fset 
(assign byte-r (a-constant 0) ) 
(assign byte-s (1- bb-width)) 
(paral lel-wi th-re turn 
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(para! lel-wi th-return 

(lisp (trace-path tf/1)))}) 

;bb-s-uDrd2 has the partial previous source word whose cddpcss is in bb-s-offset, 
jrotateti into alignraent with the destination 
idefucode ubi tb I t-d-a I igned- row-source 

(if (grcater-or-equat-f ixnura bb-«idth (b-constant (» S. 22.))) 
;;Fetch a bloc*^ of words into the buffer 
(sequential « »,v 

(ass i en b-temp (+ bb-s-offset (b-constant 8.))) 
(if (Tesser-op-equal-f ixnum bb-s-rou- length h-tenpl 
(goto ubi tbi t-d-al igned-rou-souPce-sTow-toop) 
(sequent iai 
(parai lei 

(assi an-vma-of f set s 1) 
(cal l^ubitbl t-block.-pead-8) ) 
(papal lei 

(assign-vma-of f set d) 
(ca i I ub i tb I t-d-a I i gned-b I ock-wr i te-S) ) 
(papal lel 

(assign bb-s-offset (+ bb-s-offset b-btock-size) ) 
(jump ubi tb I t-d-al igned-pow-soupce) ))) ) 
(if (gpeatep-op-equal-f ixnuai bb-width (b-constant (* A. 32.))) 
(sequential 

(assign b-temp (+ bb-s-offset (b-constant A))) 
(if (Tessep-op-equal-f ixnufn bb-s-pow- length b-temp) 
(goto ub i tb I t-d-a t t gncd-pow-soupce-stow- 1 oop) 
(sequential 
(papal lel 

(assign-vma-of f set s 1) 
(call ubitblt-biock-nead-A)) 
(papal lel 

(assign-vma-of fset d) 
(cal I ubi tbI t-d-a( i gned-b I ocK-wp i te-A)} 
(papal ^e! 

(assign bb-s-offset (+ bb-s-offset b-block-size)) 
t jump ub i tb 1 t-d-a 1 i gned-row-soupce) ) ) ) ) 
(goto ub i tbf t-d-al igned-pow-source-s low- loop) ) ) ) 

;;Each pass thpough this loop stopes exactly one d wopd. Each tiiie thpough, 
;;bb-s-wopd2 will have the bits to use fop the lowep part of the d word (alpeady 
;;potated into position), and anothep s wopd will be fetched into bb-s-wopd, 
;;Then s-wopd will get potated when transfepped into s-word2 in preparation for 
a s^^exl loop pass. 



13 cycles per word 

2 

4 



idefucode ubi tbI t-d-al igned-row-source-s low- loop 
( incp-wpap-s-off set-ahead) 
(parai le i-ui th-s-sccess bb-s-of fset-ahead 

(trap- if ( lesser-f ixnum bb-width (b-constant 32.)) 
ub i tb I t-d-a i t gned-pow-soupce-dono) 

(assign byte-s (1- bb-i-bi tpos) ) 

(assign td-s-wopd tlogxop bb-constant tienopy-data) ) ) 
(assign byte-p (- (b-constant 32.) bb-s-bi tpos) ) ;1 
(assign-vma-of f set d) ;1 ^ 

(stope-word (dpb bb-s-wopd byte-s byte-p bb-8-wopd2) ) ;1 
(assign bb-width (- bb-width (b-constant 32.))) ;1 
(incr-d-offset) ;1 

(assign bb-s-offset bb-s-of fset-ahead) ;1 

(parai lel ;1 

(assign bb-s-wopd2 (potate bb-s-woPd byte-p)) 

(i isp (trace-path ;?/.)) 

( ju.T.p ubi tbi t-d-al igned-pow-soupce) ) ) 

(de f ucode ub i tb I t-d-a 1 i gned-pow-soupce-done 
(if (plus-fixnum bb-wTdth) 
(sequent iaI 

(ass i an b-temp (32- bb-s-bt tpos) ) ;ho« many bits are valid in bb-8-word2 
(if (Tecser-or-equal-f ixnum bb-width b-temp) 
;;ue have enough s bits 
(parai iel-wi th-d-access bb-d-offset 
(assign byte-s (J.- bb-width)) 
(parai lel 

(assign byte-r (b-constant 9)) 
(assign bb-s-word bb-6-word2)> 
(parat lel 

(lisp (trace-path tt/U)) 
(para! lel-wi th-petupn 

(stope-word (dpb bb-s-woPd byte-s byte-p ■eraopy-data) ) ) ) ) 
:;need to get anothep source word 
(sequent ial 

(papal lel-wi th-8-access bb-s-of fset-ahead 
(assign byte-p (32- bb-s-bi tpos) ) 
(assign byte-s (1- bb-s-b i tpos) ) 

(assign fco-s-wopo (lonxop bb-constant «emopy-d3ta) ) ) 
(assign bb-s-uopd (dr:b bb-s-wopd byte-s byte-p bb-s-word2)) 
( I i£p (trace-path tf/S) ) 
(parai lel-wi th-d-3ccess bb-d-offset 
(assign byte-s (1- bb-uidth)) 
(assign byte-r (a-ccnstant 8)) 
(parai iel-ui th-return 

(stcre-wopd (dpb bb-s-wopd byte-s byte-p nemopy-data))))))) 
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{pa- at le! 

( ; tsp (trace-path ff/3) ) 
ireturn) ) ) ) 
;:aiu depends onty on destination bits 
(defucode ubi ttsl t-long-row-dest inat icn 

(if (pius-f ixnuBt Db-d-p! tpos) ^ *-,i ^ a 

(Sequential ^ ,, : ^i-ot) the first partial uord 

(assign b-temp (32- bb-d-bi tpos)) 



(paraTiel-ui th-d-access bb-d-of f set 
(assign byte-e (1- b-temp)) 



(ass ion byte-r bb-d-bitpos) ^^ ^ ^ ii\ 

(store-uord (logxor (dpb bb-constant bgte-s byte-r B) »emory-datan } 

(incr-d-offset) 

(assion bb-width (- bb-uidth b-temp)) 

(parallel , , ^ j. nxx 

(assign bb-d-bitpos (b-constsnt 6) ) 
(li£D (trace-path <r/b)) 
( iu«p ubi tb It- tong-row-desti nation- loop))} 
(■ach t ne-vers i cn-case 
((sin) (paral lei 

(itsp (trace-path tf/a)) 

(jufBp ubi tb I t-iong-row-desti nation- loop))} 
(otherwise (goto ubi tbl t-long-row-dest inat ion-loop) ) ) ) ) 

(defucode ubi tb! t-long-rou-dest inat ion-loop ; 25 cycles per S uords 

(if (greater-or-equal-f ixnu» bb-width (b-constant (« 5. 3Z.>)) 
;;Fetch a block of uords Into the buffer 
(sequent iat 
(paral lei 

(assign-vwa-offset d) 
(call ubitblt-block-read-S)) 
(parallel 

(assign-vma-of fset d) . « 

(ca 1 1 -and-re turn- to ub i tb I t-b I oc*t-wr » te-8 

ubi tbl t-tong-row-destt nation- loop))) 
;:Frob utth Mhafs left. Too bad dispatch blocKs are exoensive. 
(if (greater-or-equal-f ixnu» bb-width (b-constant (* 4 32,)}} 
(sequent iai 
(parallel 

(assign-vfra-of f se^ d) 
(call ub/tbtt-block-read-4)) 
(paral let 

(assign-vna-of fset d) 

(call-and-return-to ubi tbl t-block-ur i te-A ^ 

ub i tb 1 1- 1 ong-rou-dest t nat i on-s I ow- 1 oop} ) } 
(goto ubi tbl t-long-roH-destination-slou-loop)))) 

(defucode ubi tbl t-lona-row-destinat ton-slou-loop ;5 cycles per word (bus interference) 
(para 1 lei -w i th-d-access-check-wr i te bb-d-of f sc t 
(paral lei , . ^^ ma 

(assign bb-uidth (- bb-width (b-constant 32.))) , ^ ^ * *u • 

(trap- if («inus-f ixnun obus) ubi tbl t-long-row-dest mat ion-done) ) ; aborts the assign 
(paral let 

(1 isp (trace-path tf/,)) 

tuai t ing-for-memory) 

(incr-d-offset)) 
(paral le! ^ ^ ^^ 

(store-word (logxor bb-constant memory-data)) 

( jump ub i tb 1 1- 1 ong-row-dest i nat i on-s I ow- 1 oop) ) ) ) 

(defucode ubi tbl t-i ong-rou-dest inat ion-done 
(if (plus-fixnum bb-width) 

(paral lei-ui th-d-access bb-d-of fset 
(assign byte-s (1- bb-width)) 
(assign byte-r (a-constant 8)) 
lparaTlel-w» th-return 

(lisp (trace-path tf/2)) . «. ^ * x^m 

(store-word (iogxor (dpb bb-constant byte-s byte-r B) ■eaory-data)))) 
(paral lei 

(lisp (trace-path tf/D) 
(return)))) 

(def macro def-b t tbl t-blocK-read (name n) 
'(defucode ,namc 
(paral ie) 

(assign a-block-«tre (b-constant .n)) tUsed later to advance offsets 
(assign b-block-stze obus) 

(start-memory block read)) ;ct2rt first word 

(paral lei 

(wait ing-for-memory) ?watting for first word 

start-memory block read)) -.start second word 

.•(loop for t from (- n-bi tbf t-buf fers n) below n-bi tbl t-buf fers 
col iect * (abus-array-data 

(assign Tbi tb! t-buf fer ,i) 

(set-tur*e (lorjxor bb-constant memory-data) dtp-fix)) 
.(selectq (- n-bi tbl t-buf fers i) ^ 

(1 Mroturn)) 
(2 nil) 
(otherwise ' (start-memory block read))))))) 
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(defmacro def-bi tbl t-biock-uir i te (name n) 
-(defuccae .name 

(act i vate-bi t&J t -buffer) 

••^'°°^ coMecrMpiraTTef^'"*"^''^^^^'* ''^ ^'"°" n-bi tbl t-buf fers 

(store-word (bl tbf t-buf f er ,i) block) 
(parallel ^"'^ (trace-poth «/.))) ) 

(para I lei -wi tr-return 

(assign bb-widlh (- bb-wrdth (rotate b-block-size 5))) ;2^ - bi ta-per-word 

/H^!*?-!?II"^|'^'*^""'"'^« ubitbIt-block-write-8 8) 
idef-bitb! t-block-uri te ubi tbl t-block-ur I te-4 4) 

(defmacro def-d-al igned-block-ur i te (nam© n) 
idefucccie ,nane 

(assign byte-s (1- bb-s-bi tpos) ) 
(para! lei 

nlsp'T^r^cV^^?.'^;:?,',*-""^^'^ ''^ '''^^"-» ^«^«- tb-s-uord2) MocK) 
(parallel 'assign bp-9-„opd2 (potato (bi tbl t-buffer ,1) byte-r)))) 

(assian bfc-d-of fset (+ bb-d-offset b-block-size) ) 
(ca I deactivate-bitblt-buffep)) 
Iparal iel-uith-return 
(assign Pb-uidth (- bb-uidth (rotate b-block-slse 5))) ;2-S - bits-per-uord 

iie;;5co;5r[;pitS?t-"ri^5-ro!°n;??.sr -"*"«*-" bu, 

Itt (plus-f ixnum bb-d-bi tpos) 

(sequential 

(assign b-tetsp (32- bb-d-bi tpos) ) 
Iparai lef-wi th-d-acceaa bb-d-offset 
(assign byte-p bb-d-bitposJ 
assign byte-s (Z- b-temoH 
(store-word (dpb bb-CDnstant hii + « « ►,.,*-. 
(incr-d-offset) constant tyte-s byte-r meniory-data) ) ) 

Iplrallel*'""*'^*^ ^" bb-uidth b-temp)} 
(assign bb-d-bitpos fb-constant 0)) 
(lisp (trace-patn tf/b)) 

(paralVei ''^' ^^' ^-'°"Q-^°"-"ei ther-loop) )) 
(lisp (trace-path tf/a)) 
(jump ubttbit-Iong-rou-neither-loop)))) 

^"^tf f ^?n^^^ ' *^ ' *- ' ong-rou-ne i ther- 1 oop 

' l^epuen^i^r*^"^'-^'^""-^^-"'^^^ tb-constant (.8. 32,))) 
(parai tel 

(assign-vna-offset d) 

|ai^^f^^b;^fs^ 

(d,apatch-after-next (parallel (assign b-blocK-,i« ( Idb bb-uidth 3 5) ) 
((7) (parallel (a„ig„-v«3-oll2et V"^'' ' ^'" 

(cal l-and-return-to store-block-bb-constant-7 
((G) (parallel (assign-vma-of fset d""' *"' ^"'°"^"'"°"""'' ^'^"■-^'"'•f''" 

(cal l-and-return-to •tore-block-bb-constant-B 
((5) (parallel (assign-vma-of fset d""'^"' *"'°"9-'"'="-"«' t^sr-f inieh))) 

(cal l-and-return-to Btore-block-bb-constant-S 
((4) (parallel (assign-vma-of fset d""' *"' *"'°"^"''°""""' *^"'"-*'"'»f''>' 

(cal l-and-return-to •tore-block-bb-constant-A 
((3) (parallel (assign-vma-of fset d""' *"' *'"'"°"'"''""""' ^^^i-^ '"!«fi>' ) 

(cal l-and-return-to 8tore-block-bb-constant-3 
((2) (parallel (assign-vma-offset t," "'°"°"'"°"'"'' *^"''-*'"'«f'>>' 

(cal l-and-return-to 9tore-block-bb-constant-2 
(d) (assign-vma-offset d) ""'*"' <-'on3-rou-nei ther-finish))) 
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Tparal tel "" — - 

{( isp (trace-path U/,)) 
(store-word bb-constant) 
' ,■ (jump ubi tbi t-tong-row-nei ther-f inish)))) 

{paral lei 

(take-dispatch) 

(trsp-if izero-f ixnuni b-block-size) ubi tbU-long-pou-nel thcr-f tnieh) )))) 

(defucode ubi tbi t-Iong-row-nei ther-f inish 

(assign bb-d-offset (+ bb-d-offsat b-biock-size) ) 
(assign bb-wtdth (iogand bb-width ib-constant Uo27))) 
(if (plus-fixnuffi bb-width) 

(parai lel-ul th-d-access bb-d-of fset 
(aasinn byte-r (a-constant 0)) 
(assign byte-s (1- bb-uidth)) 
(paralict 

(I isp (trace-path U/D) 

(stope-wopd (dpb bb-constant bute-s byte-r *emopy-data} ) 
(return))) 
(paral iel 

(I isp (trace-path ff/1) ) 
(return)))) 

(defiBacro store-block-bb-constant-rout ines (n) 
•(progn 'coffiDi ie 

••(loop with 9 - -STORE-BLOCK-BB-CONSTANT-vd- 
for i from n dounto 1 
collect '(defucode ,(f intern s i) 
(paral let 

(store-word bb-cons:ant block) 
(lisp (trace-path U/ ,)) 
.(if (> i 1) 

• (jufTp , (f intern s (1- i))) 
•(return))))))) 

(store-btock-bb-constant-rputines 8.) 

;;alu depends both source and destination bits 
(defucode ubi tb I t- long-row-both 
(parallel 

(assign b-te«p bb-d-bi tpos) 
(if (zerc-f ixnum bb-d-bttpos) 

(if (:ero-ftxnum bb-s-bitpos) 

(goto ubi tbt t-al ic!ned-row-Doth) 
(paral fel-wi th-s-iccefls hb-^-off«pt 
; ; SS53SSS££SSS£S5S5S£55SSSS£5S. i 
; : ddddddddddocidddriddddddJdicidddddd. 
(assign byte-r (22- bb-s-oi tpos) ) 
(para7;e( 

(assign bb-s-uorri (rotate memory-data fcute-r)) 
(lisp (trace-path ;:f/c)) 
(ju.-np ubitbl t-d-ai ianed-rou-faoth)))) 
lif (equai-f iwnum bb-s-bitpos b-temp) 
(tequent iai 

(parallel -wi th-s-access bb-s-offset 
! : S££S5£SSSS£3SSS3S££S£5£S£S. sSlsss 
; ; dddddddddddddddddddddddddd. dddddd 
(psral Iel ^ 

(assign bute-r (32- bb-s-bl tpos) ) 
(asEign b-temp obusU 
(assign byte-s (31- bb-s-bitpos)) 
(assio^-Sy^eTbS^tbi^Eo^^ bb-constant (Idb .enory.data byte-s byte-r)))) 
(pnraliel 

(ass ign-vma-of fset d) 

5 ?5553£SES5£5SS3SSSSSSSS5SSS. 8S858S 

; : DODCDOCDDDDDDQDDODDDGaDDDO. dddddd 
(ca I t bb-byte-a I u-operat i on-d i spa tch) ) 

Unc^^wragfs'ifisS?)' ''°'"'- *""" *"'° ^''^""^^ "" 

(incr-d-offset) 

(assign bb-width (- bb-width b-te«p)) 
(ass I on bb-s-bitpos (b-constant 0)) 
(paral let 

(assign bb-d-b?tpo9 (b-constant 0)) 

(i ifp (trace-path U/t)) 
fufrp ubitbl t-ai igned-rou-both))) 
nf liesser-f rxnum bb-s-bitpos b-temp) 

(goto ubi tbit-ionq-row-both-s-longer) 

(goto ub ( tb I t- I ong-row-both-8-8hor ter ) ) ) ) ) ) 

(defucode ubi tbI t-long-row-both-s-lonner 
lasstan b-temp (32- bb-d-bi tpos) ) 
(parai lel-wi th-s-access bb-s-offset 

assign bute-r (32- bb-s-bitpos)) 

assign byte-s (1- b-tertp)) 

lass ion bb-s-word2 mproru-data) ) 
: : 8ss££SS3SSS?^3S£SS£££5££3. . ° 
; ; DOuJuOOCLCaDOjuDDDCDdddddddddddd 

;; *- b-tCT.p f 

f!^'??.^?il;^!sy^L=lisslliilel^* <rotafbb...«ord2bgte-r))) 

(parallel 



. 88S8 
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(assign byte-r bb-d-bi tpos) 
(assign b-temp-2 bD-d-bitpo£)3 
(parallel 

f-assign-vrrta-of f set d) 

; ; SSSSSESSSSSSSSSESSSSSSSS. ssssssss 

;; DODu^uuuuDD0DDDu:::0.ddddddddc!ddd 
( i ncrii-oM^^If ^ ' u-operat i on-d i spatch) ) 
;;Re.a^^^^^^ 

; ;555SS£«£SSS£SS5SS£ESSS9S. 5SSS53SS 

: ; dddddddddddddddddddd, dddddddrtdddd 
assign byte-r (- b-temD-2 bD-s-b i tpos) ) 
dssign fcD-s-bitpos (+ bb-s-bitpos b-tcrp)) 
assign bb-s-word (rotate bb-s-word2 byte-r)) 
ass.cn bb-u.dth (. fcb-width b-terrp)) 
tparal lei 

(assign bb-d-bi tpos (b-constant 0)) 

! isp (trace-path n/6)) 
( jump ubt tbjjj- d-al igned-rou- both) ) ) 
:Need two S words to do the first paptia!^ word 
(defucode ubi tbl t- (ong-row-bcth-»-shorter 

;; ft8SS5SSSS59SS55S83SS8SSS.89SSSSSS 

; ;dddddddddddddddddddddddddddd. dddd 
(paral lef-ui th-s-acc«ss bo-s-of fset 

Jaseign byte-r (32- bb-s-bi tpoe) > 

tassign bute-s (31- bb-a-bi toos) ) 

; : SSSSSS3SSSS5SSSS5SSS55S5. ssssssss 

; ; dddddddddddddddddddddddddddd. dddd 

ui^rlTzpttlTillVillT^V ""-""'»="* "* -"or-j-data byte-s bute-r)))) 

;; 4 ► 8.bitpos-d,bi tpos 

::...SSSS I sssssssssessssssssssssss* ssssssss 
; : dddd dddddddddddddddddddddddd. dddd 
(paral iel-ui th-s-access bb-s-off set-ahead 

{assign byte-s (- bb-s-bitpos b-tenip 1)) 

(assign byte-r (32- bb-s-bitpos)) 

;; dddd dddddddddddddddddddddddd. dddd 

(assign bb-s-uord (dpb bb-s-word2 byte-s bute-r bb-s-wcpd)) 
(assign byte-r bb-d-bi tpos) ^ r do s Wwro; ; 

(assign byte-s (31- bb-d-bi tpos) ) 

;:...8S8S}SS558S5SSSSS8SSSSSSS8SSS «««««««« 

:: DDOO OODOOODODOOOOOODOOOOOODD: SS" 
tpara lie) 

(assign-vma-of fset d) 
(call bb-byte-afu-operation-dispatch)) 
(locp-d-offset) 

**'**3" ^*^"'"°^^'*^ bb-8-off set-ahead) 

;;,-.S5SsSSSt8SSSSS8S5SSSS9S8SS8SSSGS.8SS8S8S8 

: : dddd dddddddddddddddddddddddd. dddd 
(assign byte-r (- b-terip bb-s-bitpos)) 

(paral le ! 

(assign bb-d-bi tpos (b-constant 0)) 
(lisp (trace-path U/^)) 
(ii«p ubi tbit-d-al igned-row-both))) 
(defucode ubi tb! t-alioneri-row-both 

.^Fpffir;®^:*'^!:'^':*''**''^"' t^b-width (b-constant (* 8. 32.))) 
:;Fctch a block of uords into the buffer '^^-^tJ 

(sequential 

(assiqn b-tewp (+ bb-s-offset (b-constant 8.))) 
(If (lesser-f ixnuflj bb-s-rou-lcngth b-temp) 
(goto ubi tbit-al igned-row-both-afow-looD) 
(sequent lai ^ 

(parai lel 

(assign-vma-offset s) 
(call ubitblt-block-read-S)) 
tparal le) 

(assign-vma-offset d) 

(Sequential "*'"'^''* '*'""" bb-width (b-cons?an? U 4 32J?) 

(?f*i?2.5"*^!?'' ^"^ ^b-s-offset (b-constant 4.))) 
tif (lesser-f ixnuiB bb-s-rou- length b-temp) 
goto ub I tb I t-a I i gned-rcw-bo th-s I o«- ( oop) 
isequent i a I ^ 

(p3ra) let 

(assign-vma-offset c) 
(call ubitblt-block-rcad-4)) 
(paral lel 

(assign-vma-offset d) 

(ca I I -and-re turn-to ub i tb ! t-b I ock-a I u-4 

(goto ubitblt-al igned-ro«-both-Sloul|;oi)?))'''"°"'^°*^-"'°^^ 
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laetucode ubitblt-aligned-rou-both-stcw-loop tl2 cuclcs per word 

(tpap-if (lesser-f ixnua bb-uidth (b-conatant 32*T) 

- ubi tbi t-af icned-rou-both-Gfcw-loop-done) 
(wai tmg-for-»eraory) 

(assign bb-s-word (iogxor bb-constant »eBoru-data)> ) 
. (para I lei -l+a cucIa. 

(assign^vma-offset d) ' ^^^^^ 

(cati bb-uord-alu-operation-drspatch)) 
(assign bb-uidth (- bb-uidth (b-constant 22.))) •! cucle 

Ll^*^:M^fP"''°^*"*^ 52 cycles ^ 

(parai lel •! cucle 

(incr-d-offset) '"^ *^^^'® 

(I isp (trace-path #/,)) 

(juwp ubi tbit-ai igned-rou-both)}) 

(def ucode ub i tb ! t-a I i gned-row-both-s I ow- f oop-done 
(if (plus-fixnuB bb-uidth) 
(sequential 

(para) lel -with-9-access bb-s-offset 
(assign bute-r (b-constant 0)) 
(assign byte-s (1- bb-width)) 

(assign bb-8-uord (iogxor bb-constant »emoru-d3ta))) 
iparai le ! 

(I Jsp (trace-path tt/2)) 
(assign-vma-offset d) 

(iuntp bb-byte-alu-operation-dispatch))) ;jcaM 
(paral lel-with-return »j^a'i 

(lisp (trace-path tf/l )))) ) 
(defucode ubi tbf t-block-alu-8~ 



(dispatch-after- this (Idb bb-alu-operation 4 8) 
(parat lel 

(assign a-block-size (a-constant 8J) 

(assign b-biock-size (a-constsnt CI.)) 
,,, ^, , (start-«emory block read)) ;start first word 

(d 2) (ooto ubi tbtt-block-looand-8) ) • K*y •>c(tu 

((4 8,) laoto ubi tblt-block-andc2-S)) • x*^y *x*2y 

((G 3.) (goto ubi tbi t-biock-logxcr-8) ) • x xor y, **x xor u 

((7 11,) (goto ubitbl t-block-logior-S)) . x+y, *-x4y 

((13. 14.) (goto ubi tbit-btock-Tognand-S)))) ; -*(**x»y) , -^(x*y) 

(defucode ubi tbi t-block-afu-4 

(dispatch-after- this (idb bb-aiu-operat ion A 8) 
(paral lel 

(assign a-biock-size (a-constant 4,)) 
(assign b-bicck-size (a-constant 4,)) 
,,, ^, , (start-Kemory block read)) ;start first word 

\\l i\ ^?°*° ub(tblt-b!ock.|ogand-4)) . x*y •xaicu 

J^ §• (goto ubitbl t-block-andc2-4)) . x*^y -vx^y 

{(S 9.) (Qoto ubitblt-block-iogxcr-4)) ; x xor y. Ji xor u 

\iU^;l W*° ubitblt-block-loQicr-4)) x+y, J^lu ^ 

((13. 14.) (goto ubitblt-block.Tognand-4)))) ; ^(2x*y),%r(x»y) 

(defaacro def-block-aluop (name, n alu) 

(if (Decq (get (caddr (microexpand M.alu a-temp b-temp) ) ) 'alu) ueird-alu-functions) 
:; Cannot siaul taneously run ALU and store into the bi tbI t-buf fer 
* (defucode ,naBe 
(parallel 

(uaiting.for-«emory) jfirst word already ttarted 

(declare-wettory-tmmg active-cucfe) ) 
.•(loop for i from (- n-bi tbI t-buf fers n) below n-bi tbI t-buf fera 
collect '(sequential 

(abus-array-data 
(assign b-temp (,alu (bi tbI t-buffer J) «emory-data) J 
»(if T> (. n-bi tbI t-buf fers t) 1) 

. /f*^^''^*""^^^ ^^0^^ read))) ;start next word 
(paral let 

(assion (bi tbI t-buf fer ,i) (set-type b-tcnp dtp-fix)) 
,((f U (- n-bi tbI t-buf fers i) 1) 

.. w^.^.i ... '^^"""^ ,(f intern "U3ITBLT-BL0CK-ALU-URITE--d" n) ) ) ) ) ) ) 

;; Noma) case 

' (defucode ^nane 
(paral lel 

(uaiting-for-ieemory) ; first word already started 

ideclare-«emory-t iming active-cycle) 

(start-meaory read block)) tstart second word 

,«iloop for t from (- n-bi tbI t-buf fers n) belou n-bi tbi t-buf fers 
col lect Mparat tet 

(aous-arrau-data 

(assign Ibi tbI t-buf fer J) (set-type (,alu (bitbl t-buf fer J) 

■emory-data) 
r . . r dtp-fix))) 

.(selectq (- n-bi tbI t-buf fers i) 

(1 '(iunp ,(f intern "UBITBLT-BLDCK-ALU-URITE— d" n) ) ) 
(2 nt I) 
jjj^o^^eruise Mstart-Mwory block read))) ;8tart word after next 



(def-block-aluop ubi tbI t-block-logand-8 8 logand) 
(def-biock-aluop ubi tbl t-b lock- log ior-S 8 logior) 
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(def-Diock-atuop ubi tbl t-block- toaxcr-S 8 logxor) 
(def-biock-aluop ubi tbi t-blocR-cndc2-8 S endc2) 
(de-f-block-aluop uoi tbi t-biock-lognand-8 8 lognand) 

(def-block-atuoD ubi tbl t-block-logand-4 4 logand) 
(def-block-aluop ubi tbl t-b lock- tog ior-A 4 logior) 
(def-block-alucp ubi tbl t-bl ock- ioaxor-4 4 logxor) 
(def-block-aluop ubi tbl t-block-andc2-4 4 andc2) 
(def-block-aluop ubi tb t t-b lock- iognand-4 4 iognand) 

(def macro def-block-alu-wri te (name n) 
Mdefucode ,nar;s 
(paral lei 

(assign-vma-of f set d) 
(call activate-bi tbl t-buffer)) 
♦•(loop for i from (- n-bi tbl t-buf fers n) belou n-bi tbl t-buf fcps 
col lect '(pa-al lei 

(store-word (bi tbl t-buf fer ,i) block) 
(lisp (trace-path <?/,)))) 
(parat lei 

(assign bb-d-offset (+ bb-d-offset b-b lock-si re) ) 
(call d-^activate-bitblt-buffer)) ^ .^ 

(assiqn bb-uidth (- bb-uidth (rotate b-biock-size E))) ;2^ • bt ts-per-word 
(paral lei 

(assign bb-s-offeet (+ bb-s-offset b-block-size) ) 
(return)))) 

(def-block-a!u-wr 1 te ubi tbl t-bi ock-a I u-ur i te-8 8) 
(aef-btock-alu-uri te ub i tbl t-b I ock-a I u-ur i te-4 4) 

Each tiae through the loop, s-word uas fetched from mentort; tike 
#. s.bt tpcs — • 

6SSSS8S855. 

and then rotated so it looks like 

6SS8S5S86S 

*- — 8. b i tpos ► 

Each tine, another 0-uord2 gets fetched and deposited into s-word like 
|«- s.bi tpos — - — ► 

2222222222 2222222222222222222222 ^ 

The rotation for the dpb equals the rotation for setup for next locp. 

bb-8-uord has the partial previous source word whose address is in hb-»-offset 
rotated tnto altgnraent with the destination, but not xored with bb-constant 
defucode ubi tbl t-d-al igned-row-both 
(if (greater-or-equa!-f ixnuia bb-uidth (b-constant (« S. 22.))) 
:;Fetch a block of words into the buffer 
(sequent iat 

(asoian b-temp (+ bb-s-offset (b-constant 8.))) 
(if (lesser-or-equal-f ixnum bb-s-row- length b-temp) 
(go 1 ub i t b 1 1 -d-a I i gned-row-bo th-a i ow- 1 oop) 
(sequential 
(paral lei 

(assign-vma-offset s 1) 
^ (call ubitblt-rotated-block-read-8)) 
(paral lei 

(assign-v«a-offset d) 

•.p^«^ . •♦i^^ii:?"*^T^?*"^";^° ubitblt-block-alu-8 ubi tbl t-d-a I i gned-row-bo th) ))) ) 
:;Frob w.th what s left. Too bad dispatch blocks are expensive, 
(tf greater-or-equal-fixnua bb-width (b-constant (*4 22.))) 
(sequential 

(assign b-temp (+ bb^-s-offset (b-constant 4.))) 
(if lesser-or-equal-f ixnum bb-s-row- length b-temp) 
(goto ubi tbl t-d-ai ignsd-row-both-slow-loop) 
(sequent iai 
(paral le! 

(assign-vma-offset s 1) 
(cal I ubi tbl t-rotated-block-read-4)) 
(paral lei 

(assign-vma-offset d) 

(cai l-and-return-to ubi tbl t-block-alu-4 

/««*^ ^■*wi* ^ .. ^ ubitblt-d-alicncd-row-both-8low-loop))))) 
(goto ub I tb I t-d-a I i gned-row-both-s I ow- I oop) J ) ) h w 

(dafucode ubi tbl t-d-a I i gned-row-both-s low- I oop -17 cycles per word 
(incp-wrap-s-off set-ahead) ^2 

(paral lel-ui th-s-acces3 bb-s-off set-ahead -4 

(trap-if (lesser-fixnum bb-width (b-constant 32. ) ) ' 
ubi tbl t-d-at igned-row-both-done) 

(assign byte-s (I- bb-s-bi tpos) ) 

(assign bb-s-word2 memory-data)) 
(assign dyte-r (32- bb-s-bi tpos) ) -1 

(assign bb-s-word (dpb bb-6-word2 byte-s byte-r bb-s-word) ) tl 
(assicn bb-s-word (iogxor bb-constant-a bb-s-word)) *1 

(paral lei .i .3 • 

(assign-vma-offset d) 
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(ca! I bb-word-aiu-operation-dispatcnii 
(assign bb-uidth (- bb-width (b-constant 32.))) ;1 
(incr-d-of f set) ;1 

(assign bb-s-offsct bb-s-of feet-ahead) ;1 

(■parallel ;1 

(assign bb-s-word (rotate bb-s-uord2 byte-r)) 

(I i sp" (trace-path U/,)) 

(jump ubi tbi t-d-al igned-rou-both) ) ) 

5;At entry, ue have s-word fetched from nernopy like 

; ; «- 8. b i tpOs' ► 

; -.ssssssssss 

;;but then rotated so it locks like 

:; 8SSSSS8SSS 

.;♦... — -s.bi tpos ► 

;;Tht8 IS to be combined with d-uord which looks like 

: : dddddddddddd 

;; i uidth — ► 

(defucode ubi tbI l-d-al inned-rou-both-done 

(a£sir:n bb-s-word (loaxor bb-constant-a bb-s-uord)) 
(if (plus-f ixnum bb-uldth) 
(sequential 

lassign b-temp (32- bb-s-bi tpos) ) 
(if ( lesser-cr-equai-f ixnum bo-uidth b-temp) 
;;we have enough s bits 

• ;♦. 9,tjl tpos »•- a. terp — -» 

i! assssssssssssss 

; ; dddddddddddd 

:: 4- — width — -» 

(sequent ia! 

JBSsipn bute-r (b-constjnt 0)) 
(assign byte-s (1 - bb-width)) 
(parat lei 

(assign-vma-of fset d) 

(1 isp (trace-path U/U)) ^ 

(jump bb-byte-a/u-oper at ion-dispatch) ) ) ; jcal 1 
;;need to ^et another source word 
; ;^ B.bi tpos -*^ 3. terrp ► 

♦ . ssssssasGssssss 

; ; «... dddddddddddddddddddd 

. , 4 u i d tti ► 

(sequent i a! 

(parai lel-wi th-s-ficcess bb-s-off set-ahead 

(assign byte-r b-temp) 

(assign byte-s (1- bb-s-bi tpos)) 

(assign bb-£-word2 (Irnxor nemory-data bb-constant) ) ) 
(assign bb-8-ucrd (dpb bb-G-word2 byte-s byte-r bb-e-wcrd)) 
(assian bute-r (b-constcnt 0)) 
(assign byte-s (1- bb-width)) 
(parallel 

(assign-vma-of fset d) 

(I isp (trace-path U/S)) 

(jump bb-Dyte-aiu-operation-diBpatch) ) ))) ; jcal I 
(para I lel-wi th-return 

(lisp (trace-path «/3) ) ) ) ) 

;bb-8-word has the previous source word, rot::ted but not Kored with bb-constant 
;3 cycles per word seetRS to be the best I can do (can't rotate while storing in bi tbt t-buf fer) 
;If pb-s-word was Kored already, it would take 4 cycles per word here 
(defnacro def-bi tbi t-rotated-block-rcad (name n) 
Mdefucode .name 

(assiqn byte-s (1- bb-s-bi tpos) ) 
(paraT lei 

(assign a-block-size (b-constant- ,n} ) ;Used later to advance offsets 
(assign b-biock-size obus) 

(start-memory block read)) ;8tart first word 

(paral lei 

(wai t ing-for-memory) 5 waiting for first word 

(assign byte-r (32- bb-s-bi tpos) ) ) 
,«(ioop for i from (- n-bi tbt t-buf fers n) below n-bi tbI t-buf fera 
append M (abus -array-data 

(assign ob-3-word2 (dpb aemory-data byte-s byte-r bb-s-word))) 
(paral lei 

(dscl are-memory- timing data-cycle) ;nO holds 
(assign bb-s-taord (rotate »eraory-data byte-r)) 
, (and (> (- n-bi tb! t-buf fers i) 1) 
•(start-memory block read))) 
(paral tel 

(assinn (bi tbl t-buf fer ,i) 

(set-tupe (logxor bb-constant bb-s-wopd2) dtp-fix)) 
,(if (- (- n-bT tbl t-buf fers i) 1) 
Mreturn) )))))) 

(def-bi tbl t-rotated-block-read ubi tbl t-rotated-block-read-8 8) 
(def-bi tbl t-rotated-biock-read ubi tbl t-rotated-block-rcad-4 4) 

(defucode ubi tbl t-long-row-aource-backwards 
(para! iel 

(assign b-te«p bb-d-bitpos) 
(if (zero-fixnum bb-d-bitpos) 

(i f (rero-f ixnum bb-s-bi tpos) 
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(para I lel 

n"i^(t?LTp3t^'^/ilr "-°'^"»>' 't^^e loop uill dacr first, before p=.,r 

. ( jump uD| tt)l t-31 igned-rou-source-backuarcts) ) 
(sequential 

(para) Ie/-ui th-s-access bb-s-offeet 
(assign byte-r (52- bb-s-bi tpos) ) 
{papal ief 

ofli'(t?a«:path u'l^r '"'-""^*^"* ^^°^3te .e»ory-data byte-r))) 

( •. f (equa I -I i K^nuf iI?e:p'bb!;5C i Soe)-""^"-"^''^"^^^'' ^ ' ' > 
(sequential 

(paral /el-uith-5-access bb-s-offeet 

lasstgn byte-3 (1- bb-s-bi tpos) ) 
(oaralle? Si7h'rt°a^.li°-''£'' f'«^"'ory-data bb-constant) )) 
^tcrt^Zou^^^^^^ bb-d-offset 

(paral let 

(assign byte-r (b-constant 8)) 
(assrgn bb-s-bi tpos (b-constant B) ) } 

Iplraflel " *' ^^'"'•'^^^ b-temp)) 
(assign bb-d-bitpos (b-constant 0)) 

(I lep (trace-path #/&)) 

( i f Ur« t-S ' l^ ' *'° ' ' 9"e^-':o"-»ou'-ce-baclcuard8) ) I 

'" lleluen^rir""' ""■»-'" ^Po. b-te^p) ;. > d. enouQh In the current uord 

(para I 1 e 1 -w i th-s-access bb-s-of f set 
(assign byte-s (.1- bb-d-bi tpos) ) 
(assign byte-r i- b-temp bb-s-bi tpos) ) 

(oarlflf? SiVh'H^^'^ ^'^^*'°^ bb-constant memory-data))) 
iparai |<5i--w) th-d-acceso-cneck-ur te bb-d-offset 

(ai^^^;;%p-°;-^i;sv^^ti;s°cg-S^;i-^^ 

(pIraTlel bb-width b-temp))^ 

(decr-d-offset) 
(lisp (trace-path ff/d)) 

(sequintial""*"'*"'^"^' 'Sned-rou-source-backuards))) 

(parallel-uith-9-access bb-s-offset*^* """^ *° ^"*^^ another word 
(paral le I 

(assign byte-r (- b-temp bb-s-bi tpos) ) 
(aif r|^^Sy?;:r ?li-a^t^Sp"?) ""-"-'' ' ''°'' ' ' 
i/errtLr^,^.r4rii:Ul,ttT ""-""'^^^t (rotat. r.«oru-data byte-r))), 
(paraliel-mth-e-access bb-s-off set-ahead 
(assion^Sh S"!;;tI2'"nJ'?3>«or bb-constant wmory-data))) 

lp%r%??e?-':?;;?f Sf a^iS^o'Sbf^^JS^^L?"*-' "«*-" '=^-"-«^» ' 
assign byte-r (b-constant 8)) 
(assign byte-s (1- bb-d-bi tpos) ) 

(store-word (Idb bb-s-word bute-s bute-r M.&nr.. Haf^m 
asGign bb-s-bi tpos (32- a- temp)) ^ "eaory-data} ) ) 
assign byte-r a-temp) *^ 
(assign bo-a-uord (rotate bb-s-word2 buta-r)) 
iimrn ^^'^-^ll^V '=^-«7bf^set-Iheid)^^* '^^ 
iasQign bb-wrdth I- bb-width b-ternp)) 

(P3ra??e*?^'^'^'*^°' (b-constant B)) 
(decr-d-offset) 
(I tsp (trace-path ff/e)) 

( jurap ub i tb I t-d-a J i gned-row-source-backwards) ))))})) 
;bb-s-offset is 1+ the "real" value at this point 

''(dec?-Sr^^::^i^;^i;r'-'"""'°"^"''^^^"^^^^ if ^«^'" p- "-^ 

(paral iel-wi th-s-access bb-s-of fset '4 

(trap-tf (tesser-f ixnum bb-tiidth (b-constant' 32, ) ) 
ub ( tb ( t-a I i gned-row-courcs-backwards-done) 

(wai ttng-for-nemoru) 

(assign bb-s-uord Jlogxor bb-constsnt «ie»oru-data) ) ) 
(assign-vma-of fset d) y uai-a/;/ 

(store-word bb-s-word) Ii 

(assign bb-width (- bb-width (b-constant 32.))) -1 
(poralle/ »i 

(decr-d-offset) ' 

(lisp (trace-path <?/.)) 

(jump ubi tbi t-a I igned-row-source-backwards) ) ) 

^^TfV^Tf? ubi tb I t-a I igned-row-cource-backwards-done 
(if (plus-f txnum bb-u idt.hi 
(seauent iai 

(paral Iel-wi th-s-access bb-s-offset 
(assign byte-s (1- bb-width)) 
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(assign fcyte-r bto-width) 

(assign bD-s-wopd (togxor bb-constant (Idb uemcry-data byte-a byte-r}))) 
(parai lei-wi th-d-access bb-d-of f set 
(assign byte-r (32- bb-widtM) 
'(paraTlel-wi th-return 

(store-word (dpb bb-s-uord byte-s byte-r menory-data) ) 
(I isp (trace-path n/2))))) 
(para! te l-wl th-pe turn 
(I isp (trace-path #/!))) )) 

;;each time through the loop, bb-s-uord has the lou part of the previous word 
;;rot3ted to be at the high end of the uord* Ue use it as background to LD3 the 
;;high part of the next uord into It. 

•bb-8-offsct is 1+ the "real" value at this point 
;could bum one cycle by Boving assigntnent to byte-t out of loop, 
;but this shculd use bTocK mode anyway 

idefucode ubi tbi t-d-al igned-ro«-eource-backuards ;11 cycles per uord 
(dccr-urap-s-cf fset) ;1 

(paral lel-with-s-access bb-a-offset :A 
(tP3p-)f ( lesser- f I xnurr bb-width (b-constant 32.)) 

ubi tbi t-d-al igned-row-scurce-backwards-donc) 
(assign byte-r (32- bb-s-bi tpos) ) 

(assign bb-s-word2 (iocxor bb-constant aemory-data) ) ) 
(asGian byte-s (31- bb-s-bi tpos) ) ;1 

(assign-vrta-offset d) ;1 

(store-word (Idb bb-8-uord2 bute-a byte-r bb-»-word)) :1 
(assign bb-uidth (- bb-width lb-constant 32.))) ;1 
(decr-d-offsct) ;1 

(parat tel •! 

(ass; an bb-s-word (rotate bb-s-uord2 byte-r)) 
(I isp (trace-path U/.)) 
i jump ub i tb ( t-d-a I i gned-row-aource-backuards) ) ) 

(de f ucode ub i tb I t-d-a I i gncd-row-source-bacKwarda-done 
(paral iel 

(assign bb-width-b bb-uidth) 
(if (plus-fixnum bb-width) 

(if (greater-or-equal-f ixnum bb-a-bltpos bb-width-b) 
(parallcl-wi th-d-access bb-d-offset 
(assign byte-r (b-constant 0)) 
(assign byte-s (31- bb-wtdth)) 
(paral lel-wi th-return 

(store-word (Idb «emory-d3ta bute*s byte-r bb-a-uord) ) 
(lisp (trace-path U/k)i)) 
(sequent iai 

(paral lel-wi th-s-access bb-s-offset 
(assign byte-r bb-width) 

(assign bb-s-word (rotate bb-s-word byte-r)) 
(assign bb-s-word2 (lonxor bb-constant nemoru-data) ) ) 
(parallel 

(assign byte-r (- bb-width-b bb-a-bt tpos) ) 
(assign a-tcrnp obus) ) 
(assign byte-8 (1- a-terp) ) 

(ass ion bD-3-word i)&o bb-e-word2 byte-5 byte-r bb-a-word)) 
(paraT lel-wi th-d-acceas bb-d-offset 
(assign byte-s (1- bb-uidth)) 
(assign byte-r (32- bb-width)) 
(paral lei-wi th-return 

(store-word (dpb bb-s-word bute-s byte-r aesoru-data) ) 
(lisp (trace-path #/5)))))) 
(paral lel-wi th-return 

(licp (trace-path n/2)))))) 
lasatgn b-temp bb-d-bitpcs) 
(if (rero-f ixnum bb-d-bitpos) 

(if (rero-fixnu» bb-s-bi tpoa) 
(paral Iel 

(assign bb-s-offaet (1+ bb-s-offset)) ;Ioop will deer first before pclcr 
(I iep (trace-path ^/a) ) 

(jump ubi tbI t-al igned-rou-both-backuards) ) 
(paral lel-wi th-»-access bb-s-offeet 
(assign byte-r (32- bb-s-bi tpos) ) 
(parallel 

(assign bb-s-word (lonxcr bb-conatant (rotate •cmonj-data byte-r))) 
(lisp (trace-path tf/c)) 

( jump ubi tb ! t-d-al igncd-row-both-bacKwards) ) ) ) 
(if (equal -f ixnuffi b-tcmp bb-s-bi tpos) 
(sequent iaI 

(paral ie!-wi th-»-access ba-s-offset 
(assign byte-a (1- fcb-e-bi tpcs) ) 
(assign byte-r (b-constnnt 8)) 

(assign bb-a-word (losjxcr bb-conatant Bemory-data) ) ) 
(parai le/ 
^ (ass»gn-v«a-of f set d) 

(cat I bb-bt^te-a/y-operat ion-diapatch)) 
(assign bb-M»dth (- bb-width b-temo)) 
(assign bb-s-bi tpos (b-ccnstant fi)) 
(assign bb-d-bitpoa (o-constant Q)) 
(paraTtel 

(decr-d-offset) 

(lisp (trace-path ;!f/D)) 



4,887,235 
539 540 

(jump ubitblt-al igned-rou-both-bacKuards))) 
(If oreatep;fi>cnuB bb-s-bitpos b-tesp) -.e > d. enough in first word 

leequent i ai 

(paral iel-uith-s-access bb-s-offset 

(para I lel 

(assign byte-r (- b-teap bb-s-bi tpos) ) 
(assion a-temp obus)) •this Is negative 

(assign byte-s (1- fcb-d-bi tpos) ) 

(assign bb-s-word ( logxor bb-constant (rotate tjemory-data byte-r)))) 
(assion byte-p (b-constant 8)) ^ r;/// 

(para! [el 

(assign-vna-of fs£t d) 

(cal I bb-byte-aiu- operation-dispatch) ) 
(assign bb-s-bitpos (- bb-s-bitpos b-teicp)) 
(assign bti-d-bitpos (b-constant C) ) 
(assign bb-width (- bb-uidth b-tectp}) 
(parallel 

(decr-d-offset) 

(I isp (trace-path tt/d)) 

( jump ub i tb I t-d-al i gned-rou-both-backwards) ) ) 

?n^^2nfl ;*K , .. W^^ ""^^"^ *° ^«*ch another uord 
(PwraMe!-w(th-8-acces3 bb-s-offset 

(assign outa-r (. b-tensp bo-s-bi toos) ) 
(decrf^^Sp-sIcTfs^^JS^ bb-constant (rotate .e-crg-data byte-r)))) 
(para! Ie:-ui th-s-acceas bb-s-of fset-ahead 

(assign a-temp (- b-temp bo-»-bi tpoa)) 

(assign byte-s (1- a-temp)) 

(assign bD-5-word2 (logxor bb-constant nemory-data) ) ) 
assign bb-s-word (Idb bb-9-word2 byte-e byte-r bb-s-word)) 
assign byte-s (i- tb-d-bi toos) ) « ^ 
asDtqn byts-r (b-constant fi)) 
(paraTle) 

(assign-vm3-off«;et d) 

(call bb-byte-alu-operation-dispatch)) 
(parat iel 

(assign a-temp (- b-temp bb-s-bi tpos)) 

(assign byte-r obus)} 
(assign bb-s-uord (rotate bb-o-ucrd2 byte-r)) 
(assign bb-s-titpos (32- a-te::ip)) 
acoign bb-s-offset bb-s-of fset-ahead) 
(assign bb-d-bitpos (b-constant G) ) 
aesictn bb-yidth (- bb-uidth b-temp)) 
(paral lel 

(decr-d-offset) 

(i isp (trace-path /?/e)) 

(jump ubi tbi t-d-al igned-row-both-backuards) )) )) ))) 

•bb-9-offset is 1+ its "real* value 
; bb-s-uord has the previous uord, rotated and xcred 
(defucode ubi tbi t-d-a I igned-row-both-uack-kards ;14 cycles per word 
(decr-urap-s-of f set) ;1 cycles 

(paral le!-wi th-s-access bb-s-offset ;4 cijcles 

(trap- if ( lessor- ftJcnuD) bb-width (b-constant 32.1) 
ubi tbt t-d-al igned-row-fcctn-backuards-done) 

(assiqn byte-r (32- bb-s-bi tpos) ) 

(assign bb-8-iJora2 (togjccr bb-constant aemory-data) ) ) 
(assign byte-s (31- bb-s-bi tpos) ) ;1 

(assign bb-8-word (idb bb-s-word2 byte-s byte-r bb-s-uord)) ;1 cyc(e 
(parallel jl+3 cycles 

(assign-vma-of f set d) 

(cal ! bb-uord-atu-operat ion-dispatch) ) 
(assign bo-s-word (rotate bb-s-word2 Dute-r)) •! 
(assign bb-width (- bb-uidth (b-constant 32,))) ;1 
(parallel 

(decr-d-offset) -1 

(lisp (trace-path «/.)) 

(jump ub i tb I t-d-a I » gned-rou-both-backwards) 1 ) 

(defucode ubi tbi t-d-a i ianed-row-both-backuards-done 
(para I lel 

(assign bb-uidth-b bb-width) 
(if (pius-f ixnum bb-width) 

(if (greater-or-equal-f ixnuw bb-e-bitpos bb-width-b) 
(sequent iai 

(assign byte-r bb-width) 

(assign bb-s-word (rotate bb-«-word byte-r)) 

(assign byte-s (1- bb-width)) 

(assign byte-r (32- bb-width)) 

(parallel 

(assign-vma-cffset d) 
(I isp (trace-path U/U)) 

(jurr.p bb-byte-aiu-operation-diepatch))) :jcall 
(sequential 

(paral lel-wi th-s-access bb-e-of fset 
(assign byte-r bb-width) 

(assign bo-s-word (rotate bb-s-word byte-r)) 
(assign bb-s-word2 (logxor bb-conetant meraory-data) ) ) 
(parallel 

(ass i an bute-r (- bb-width-b bb-e-bi tpos) ) 
(assign a-temp oous) ) 
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■ (assiGn feyte-s (1- a-temp)) 
(ess i an ob-s-word (tdb fcc-9-wopd2 byte-s tyte-r bb-9-word) ) 
(assign byte-s (1- bb-uidth)) 
(assion byxe-r (32- bb-uidth)) 
(parallel 
(assign-vma-of fset d) 
^llsp (trace-path i!?/5)) 
(jump bb-by te-a I u-operat t on-di spatch) } } ) 
(para I lel-wi th-return 
(lisp (trace-path U/3)))))) 

:;code for Xdecode-bi tb It-arrays 

;;Take atu froffi-array to-arr2y 

;;R«turn (s-beg-addr »-beg-bitpos »-Pcu-length e-height 

;• d-bcg-3ddr d-beg-Ditpos d-row-iength d-height 

;; «rpay-rcg-event-count) 

; tares 

(defatoffltcro bbd-alu (amem (stack-pointer -2))) 
(oc'fatoaicro bbd-s-array (amea (stack-pointer -1))) 
(dcfatoaicro bbd-d-array top-of-stack-c) 

;; 4 slotr for arpay-8«tup-2d to return its results 
(defatcmicro bbd-control (ameni (stack-pointer 1))) 
(defatoinicro bbd-bace-po inter (amera (stack-pointer 2))) 
(defatomicro tbd-uidth (amew (stack-potnter 3))) 
(defatomicro bbd-height (atnew (stack -pointer 4))) 



; jcal I 



8-bi ts-per-e! t 
d-bi ts-per-el t 



(defatomicro bbd-s-beg-addr (anen (stack- 

(defatoBiicro bbd-s-beg-bi tpos iarne'n (stack- 

(defdtomicro bbd-s-row-length (amem (stack- 

(defatonicro bbd-s-height (amervi (stack- 

(defatomicrc obd-s-bi ts-per-el t (amen (stack- 

(defatomicro bbd-d-beg-addr (amen (stack- 

(dcfatocicro bbd-d-beg-bi tpos (amaa (ctack- 

(defatomicro bbd-d-rou- length (anem (stack- 

(defatoBiicro bbd-d-height (amem (stack- 

(defatoaicro bbd-d-bi ts-per-el t Cameo (stack- 

(defatoBicro bbd-event-count (anea (stack- 

(defatomicro bb-alu-depends-on-source 

(b-constant JV. (loop for atu in * 
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X eource 
;dest 
{neither 
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14. 



tboth 



turn (ash 1 alu)))) 



(defmicr'o compute-beg-bi tpos (for-uhat) 
(let ((oeg-bitpos (selectq for-uhat 

(s ' bbd-s-beg-b i tpos) 
(d 'bbd-d-beg-bi tpos) 

(otherwise (f error "Uhat is -^S" for-what)))) 
(row-length (selectq for-what 

(s 'bbd-s-row- length) 
(d 'bbd-d-rou- length) 

(otherwise (ferror ^-Uhat is -^S" for-what))))) 
Msequent iai 

(ass i en b- low-dividend top-of-stack) 
(assign a-posi tive-divisor bbd-width) 
(para I let 

(assign b-htgh-dividend (a-constant 0)) 
(assign a-divi de-step-count tb-constant 15.))) 
(para I lel 

(assign a-negattve-di visor (- a-posi tive-divisor)) 
(cal i "di vide-subrout ine) ) 



(assign ,beg-bttp05 (set-type (rotate b-hiqh-dfvidend byte-r) dtp-fix)) 

(assign b-tcwp (set-type (Tdb , row-length 27. 5 0) dtp-fix)) 

(assion bb-a-tenp b-tcirp) 

(«py-22-32 bb-a-temp b- low-dividend eet-b-temp for-effect nil)))) 

(defmicro sct-b-temp (x) 
• (assign b-tenp ,x)) 

(definst tbi tbi t-decode-arraya no-operand 
;:&ee unether the alu operation depends on the source array 
(assion byte-r (22- bbd-alu)) 
(parallel 

(assign top-of-stack (a-constant 0)) ; the "subscript" 
(if (Tdb-bi t-test bb-alu-depends-on-source byte-r) 
(sequential 
(parat let 

(check-arg-type array bbd-s-array dtp-array) 
(assign vma bbd-s-array) 
(assign b-vma bbd-s-array) 
(call array-setup-2d)) 
(parallel (assign b-temp bbd-control) 

(call bbd-bi ts-per-el t) ) 
(parallel (assign bbd-s-bi tc-per-el t (set-type b-temp dtp-fix)) 
(assign byte-r b-tenp)) 
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(assign bbd-s-row-length (cet-typo (rotate bbd-width byte-r) dtD-fix)) 
(comoute-beg-bi tpos a) 

{assign bbd-5-bea-addr (+ bbd-base-potnter b-tenp)) 
(assign bbd-B-height bbd-heinht)) 
(c&Quential 

(assign bbd-s-bi ta-per-e! t (-ict-tLfpo (a-constant 1) dtp-fix)) 
aesicn fcbd-B-rou-length (cet-type <a-constant 168303*3) dtp-fix)) 
(assign bbd-s-fceg-bi tpos (sst-tupa (a-constant B) dtp-fix)) 
(assign bfcd-s-beg-addr quote-nil) 

(assjgn bbd-s-he ight (set-tijpe (a-constant 1C33CC3) dtp-fix))))) 
;; decode the destination array 

(asston top-of-«tack Cb-constant 0)) t th» "eubscript 
(paraltel 

(checK-arg-type array bbd-d-3rray dtp-array) 

(assign vma bod-d-array) 

(assign b-vma bbd-d-array) 

(call arr3y-setup-2d)) 
(parallel (assign D-temp bbd-contro I) 

(assian bbd-event-count bbd-controt) 
(cai I'bbd-bi ts-per-el t)) 
(parallel (assign bbd-d-bi ts-per-e/ 1 (set-type b-tej:;'p dtp- fix!) 

(assign byte-r b-temp)) 
(acsign bbd-d-rou-lcnath (set-type (rotate bbd-uidth btjte-r) dtp-fix)) 
(compute-beg-bi tpos d) 

(assign bbd-d-ben*3ddr (+ bbd-base-po inter b-temp)) 
(assign bbd-d-helght bbd-height) 

;; Now copy results down over arguments and arr ay-setup-2d uork ar^z 
(assign D-temp frame-pointer) 

(assign frame-pointer (+ stack-pointer (b-constant 4)1) 
(assign b-temp-2 (+ ttacW-po inter (b-constant 15.))) 
(parallel 

(assign stack-pointer (- stack-pointer Cb-constant 3))) 

(cal I bit-stack)) 
(par2t let 

(assign frame-pointer b-temp) 

(assign tcp-of-stack top-of-stack-a) 

(next- instruct ion) ) ) 

;;take an array-register control word in b-tenp, return a decoding of its 
;:dfspatch type in b-teop. 
(defucode bbd-bi ts-per-el t 

(dispatch-af ter-this (array-register-dispatch-field b*tcitp) 
(nop) 
( (Xarrau-regi ster-di spatch-l-bi t) 

(paraTiel (assign b-temp (set-type (b-conatant 0) dtp-fix)) (return))) 
( (larray-regi ster-di 6patcn-2-bi t) 

(parallel (assign b-temp (set-type (b-constant 1) dtp-fix)) (return))) 
( (*arrau-regi ster-dtspatch-4-bt t) 

(oaraT lei" (assign b-tecip (sat- typo (b-constant 2) dtp-fix)) (return))) 
( (tliarray-reg i sier-di opatch-S-bi t) 

(parallel (assign b-temp (set-type (b-constant 3) dtp-fix)) (return))) 
( (larray-regi ster-di spatch-lG-bi t) 

(parallel (assign b-temp (set-type (b-constant 4) dtp-fix)) (return))) 
( (*arpau-reqi Ster-di spatch-uord) 

(parallel (assign b-temp (set-tupe (b-constant 5) dtp-fix)) (return))) 
(otheruiss (signaT-error unitiplemented-or-i I I egat -array- type) ) ) ) 

t;; -«- f1ode:LISP; Packaoeiflicro; Base: 8; Lowercase: T -«- 
;;j (c) Copyright 13S2, Symbolics, Inc. 

;;? Binding stack stuff 

;Address operand: special variable value cell 
;Stack operand: value to bind it to 
(definst bind-specvar indircct-operanrJ 

(acsicrn vca (- frame- funct ion nacro-unsigned-t mediate 1)) 
(parallel (start-memory read) 

(assign b-temp (1+ tbindinrt-stack-pointer) ) ) 
(error-rf (greater-pointer b-tcmp Xbinding-stack-i irjii t) 

bmd-stack-overf low) 
(parallel (transport) tPick up pointer to value cell 

(assign vma mer.ory-data) 
(jump bind-top-of-stack) ) ) 

;Ftrst arg: locative to cell to bind 
; Second ar^: value to bind it to 
(definst btnd-locat i ve no-operand 

(assign b-temp (1+ Ibinding-stack-pointer) ) 

(error- if (greater-pointer b-temp *binding-stack-t tmi t) 

b»nd-stcck-ovcrf low) 
(parallel (checK-data-typs next-cn-stack dtp-locative) 
(assign vma next-on-stack) 
(call bind-tC'P-of-stsck)) 
(parallel (for-effect (pcpval)) 
(next- instruct ion)) ) 

Stack overflow uust have been checked by here, and b-temp has (1+ Xbinding-stack-pointer) 
voa has locative to bound celt 
new-value will be popped off the stack 
(defucode bind-tOD-of-stsck 
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(paralle! (stapt-oiemory read) jread previous value 

(if (bit fpaae-bindinge-bt t) ;a"tcrrp acts eventual eecond binding wcrd 
(parallel (assign a-tewp ^set-cdp (^et-type vsia dtp-locati vs) 1)) 

{ jLf.Tp"t3ind-top-of-8tack-l) ) 
(paraliel Ussign a-teT,p (set-crlr (set-type vma dtp-locative) 0)) 
(jump bind-top-of-8tack-l) )) ) ) 

(defucode bind-top-of-atack-l 

(parallel (declare-memoru-t tning data-cycle) 

(transport bind) ; transport previous value 

(ass inn a-tertp-2 memory-data) 
(assign b-t£rp-3 irtmory-data) ) 
(parallel (assign b-ter:p-2 vna) ;b-temp-2 -> valuft cell 

(assi::n virta b-ter.^.p)) ;vn!3 »• bindinrj stack. 

(8tcre-contents"a-tcnp-2 block) jwrito to binding stack 

(store-contents a-tecp block) 
(paralle! 

(ass ion top-of-stack next-on-stack) jpop stack 
(decrement- stack-pointer) 

(assign vma b-terr!p-2M t write new value into value cell 

(store-contents (a.r.en (stack-pointer 1)) (cdr b-tefnp-3)) {preserving ce!l*8 cdr code 
(assign frame-bindi nns-bi t (b-constant D) jfinalize binding (can't pclsr ang tnore) 
(parallel (assign IbTnding-stack-pointer (+ Xbinding-s tack-pointer (b-constant 2))) 
(next- instruct ion))) 

;Called by funcall-instance-binding-icop (and closure processing if that were in nicrocode) 
(defucode bind-top-of -stack-closure 

(assign b-tcnp (1+ tbinding-stack-pcinter)) 

(error-if (greater-pointer b-tecp ibinding-stack-l imi t) 

bind-stack-cverf low) 
(parallel (start-mer^cry read) ;read previous value 

(if (iiit fra.v.e-bindings-bi t) :a-temp gets eventual eecond binding word 
(parallel (assign a-tcrp (set-cdr (set-type vma dtp-locative) 3)) 

(jump bind-top-of-fitack-D) 
(parallel (assign a-terrp (set-cdr (set-type vna dtp-locative) 2)) 
(jur.p bind-top-of-stack-l))))) 

(defnicro morc-bindings-f laq (opnd) tlow bit of cdr field 

•(parallel , (get-to^abus opnd) 

(Ido ybus-crccks-l 1 14,) J) 

;;: 8) Verify stark level 
;;; 1) Fcp locative 
;;; 2) Pop old value 

;;; 3) Tranapor t-bi nd the current-vaf ue and write cfd-vah-'e 
;;: returns locative in a-tenp-2 so that you can check cdr-ccde 
;;; nuct preserve b-temp 

(defmicro caM-unbind-i (^cptionsl retijrn) ^ 
•"(parallel (assign vma Xbinding-etack-oointer) 

(assign b-ter;>-2 Ibinding-r-tack-pointer)^ 

, ( i f return * icoi /-and-return- to unbmd-l , return) 
Mcaf i unbinJ-i)))) 

(defucode unbind*! 

(paralle) (start-nenory read) 

(error-if (greater-pointer tbinding-etack-tow b-terp-2) 
b ( nd-stack-under f I ow) ) 
(error- if (not (bit frece-bindinas-bi xjJ unbind-too-tr.any) 
(parallel (tran£;ort) 

(ass inn a-tsmp-2 «emory-data) ) ;a-tcnip-2 gets locative to value cell 
(mcmread (1- lb inding-s tack-pointer) ) 
(parallel (tranEiport bind) 

(assign a-tesip memory-data)) ;a-teBp gets old value (or evcp or null) 
(•emread a-teirp-2) 
(parallel (transport bincJ-write) ;Fol low forwards but no EVCP'e 

(assign b-teir.p-2 wemory-data) ) 
(store-content?: a-ter,p iccr b-temp-2)) jStore back old value, preserving cell's cdr 
(if (not (bit (more-bindings- flag a-temp-2))) ?Now finalize (cannot pcler any nore) 
(assign fra.-re-bindings-bi t (b-ccnstant 0)) 
(drop-through) ) 
(parallel (assign tbinding-s tack-pointer (- Xbinding-stack-pointer (b-constant 2))) 
(return) ) ) 

(definst unbind-n unsigned-iffitnediate-operand 
(if (not (bit first-part-done)) 

(sequent ial 

(puEnval (set- type (1- nacro-onsigned- immediate) dtp-fix)) 

(paralle! iatsign f irst-part-cone" (b-constant 1)) 
(cieaf-stack-ad iustfi.ent) 
(jurp unc ind-n-loop) ) ) 
(goto unbind-n-locp) ) ) 

(defucode unbind-n- loop 
(C3! i-'jnbind-l) 
(parai io! 

(assinn tcp-of-stack-a (1- top-of-stack-a) ) 
(as&irn top-of-stack ecus) 
(if (minus-f ixnuffl obus) 
(p3rat lel 

(assign first-part-done (b-ccnstant 0)) 
(aecreir:ont-st3ck-po inter) 
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( jurp f ix'jp-tCi) ) 
(goto unaina-n-iccp} ) ) ) 

(de f ucDde f rane-c i eanup-b i nd-s tack.-unw i nd 

(if (bit frorie-b i nd i ngs-i; i t) _ . . 

(ca I i -ur.D i nd-1 ' frame- ci eanup-b i nd-s tack-unw i nd) 
tretcrni ) ) 

<dcf ucodc p::p-bi nd i ng-stack-to-b-tef?rp 

(if fccu3i-pointer''ioinding-stack-pa(nter b-tcirp) 
iretLfrn) 
ical i-unbind-l pop-b inding-stack-to-b-tefflp) ) ) 

(defir.Etl Xsavs-b mding-stack-level no-operand 
(puL^val *xn r.d ing-si5ck-po I nt CP } ) 

;If you u3nt to tave one control-memopy location, make this "iaashes-stack" 

;ar.d recornile alt Li?p ccce. 

(de^inct Vrorstore-bindi no-stack- level no-operand 

(parallel (che-k-d3ia-tijps top-of-stack-a dtp-locat ive) 

(ossinn b-terp tcp-of-3tack-a) ) 
(papal iel (for-effsct tpcpva!)) 

{jump pop-bind tn-^-stack-to-b-temp))) _ 

;;; -«- flodetLrsp; Packaoerflicro; Base: 8; Loucrcaserges -»- 
:j: (c) Copypight 1332, Symbotics, Inc. 

; Hicpocode definitions fop the most basic instPuctions 

;Get defmicpo and alt his hosts 

(declare (cond ((not (status feature lnucode)) 
(load 'udcls))}) 

;;; Sone sl.*nple instructions 

(definstl push-immed s igned-iinntediate-opepand 

(pushvai (set-type eacro-signed-itiBediate dtp-fix))) 

(definstl push- local addpess-opepand 
(pushva) addpess-opepand) ) 

Cdeflnst push-addpcss-local addpess-opepand 

(if (bit-test (a-constant i_7) •acpo-signed-taaiediate) 
;Stack-pe!at i ve 

(parallel (pushva! (set-type (+ stack-pointep ■acpo-aigned-i Mediate 1) 

dtp- locative)} 
(next- instpuct ion) ) 
;Fpame-relat ive 

(papal let (pushvai (set-type (+ fpawe-pointer nacro-aigned-i Mediate) 

dtp- locative)) 
(next- instruction)))) 

;There is a wutttple gpoup at the top of the stack, and its size 
;needs to get aoded to our opepand. Ue then go that dc^n in the 
; stack and petrieve a uord. 
(definst push-from-beyond-mul t iple unstgned-iBnediate-operand 

(assign b-temp (+ top-of-stack-a ■acro-unsigned-iaaediate 1)) 

(assign xbas (- stack-pointep b-temp)) 

(papaTiel (pushvai (amem (xbas 8))) 
(next-instpuct ion))) 

;Acce«^ the constant as iiemory. even though it is stoped in A-aemopy, because 

;tP;erd! tends to be an invisible po inter thene. 

tde f 1 ns t push-» i cr ocode-escape-cons tan t uns i gned- i aned i a te-opepand 
ipiira I le I 

(assign vma (+ (a-constant (+ (get ;micpocode-escaDe-constants 'a-aemopy-block-addpess) 

(get a-aemopy-viptuai-address 'sysconstant)) ) 
»acro-uns I gned- ( fined I ate) ) 
(jump pushmem) ) ) 

(definstl pop-loca! (address-cperand needs-stack) 
(assign address-opepand (popvat))) 

(definstl «ovem- local (addpess-opepand needs-stack) 
(assign address-opepand top-of-stack) ) 

(definstl Idb-imrned 10-bi t-immediate-opepand 
(check-f i xnum-lapg-a top-of-stack-a 

(othDPuise (take-post-tpap Idb-escape ppesepve-stack)) ) 
Inewtop (set-type (Idb top-of-stack-a aacro aacro) dtp-fix))} 

(definstl dpb-immed (10-bi t-iirmediate-operand needs-stack) 
icheck-f ixnum-2apgs next-on-slack top-of-stack 

(otherwise ( take-post- tpap dpb-escape ppeserve-stack) ) ) 
ipopZpush (set-type (dpb next-on-stack aacro aacro top-of-stack) dtp-fix))) 

(definst Ish-stack (no-operand needs-stack) 
(para I lei 

(check-f ixnum-Zargs next-on-stack top-of-stack) 
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(i f (mrnus-f ixnum"iop-oT-stack) 
;Shi f t right by LDBing 

(para I id , , « . . • 

(aasign byte-s (+ (a-con»tant 37) top-of-itack)) tByt««ize-l 
(if iminu£-f ixnun: obus) 

; Shifted auay — result is zero 

(parallel (popZpush (set-type (a-conatant 0) dtp-fix)) 

(next-instruction)) 
(sequent ial ^^, . , ^ 

(assign byte-r (+ (a-constant 37) top-of-stack 1)) ;Rotate 
(parallel 

(pC)p2push (set-type (Idb next-on-stack byte-s byte-r) 

dtp-fix) ) 
(next-instpuct ion) ) ) ) ) 
;Shif t left by OPBing 
(parallel 

(assign byte-s (- (a-constant 37) top-of-stack)) jBytesize-1 
(if (minus-f ixnuffl obus) 

;5hifted auay — result is zero 

(parallel (pop2push (set-type (a-constant 0) dtp-fix)) 

(next- instruct ion) ) 
(sequent ial 

(ass ion byte-p top-of -stack) iRotate 
(parallel 
(pGp2push (set-type (dpb next-on-stack byte-s byte-r B) 

dtp-fix)) 

(next-instruction)))))))) 



(definst rot-stack (no-operand rwads-stack) 
(ass. on byte-r top-of-stack) ;Tri 



(parallel ^^^'or-^^^OK) ;Truncates to 5 bits 

(cneck-f ixnum-2arg8 next-on-stack top-of-stack) 

(SeSf!r^^tp"iio^?n*'"°'"''* "•'I'':"*'"'' ^^''''' ^^p-^-^> 

;;; flcBOpy reference Instructions 

;Put something in vma and jump here. This pushes the contents of nemory 
;a9 the result of the instruction, 

tdefucode pushmem 
(start-eemory rearf) 
(nop) 
(paral Icl (tpanspopt) 

(pushval memory-data) 

(next-instruct ton) ) ) 

;Put so»ething in vma and jump here. This puts the contents of siemory 
;on the top of the stack (replacing an operand). 
(defucode neutopmen 
(star t-acnory read) 
(nop) 
(parat lei (transport) 

(neutcp memopy-data) 
(next-instruct ion) ) ) 

;Put something in VPIA and jump here. This pushes the contents of the location 
;Frtnted to bu that location, 
(defucode pushmem ind 
(start-memory rea^i) 
(nop) 
(paral lei (transport) 

(assign vma memory-data) 
(jump pushmem) ) ) 

;Put address in VHA and jump here. Top of stack is popped and stored into 
;that memory location, ieavrng the location's cdr code unchanged, 
; Touch memory-data only once, for the sake of the tempopary memory control, 
(defucode popmem 

(parallel (start-memory read) ;Read In case of invz. store-data to B side 

(assrgn b-temp top-of-«tack-a) ) 
(tor-effect (pcpvat)) .Pop stack, adiust top-of-stack register 

(parallel (transport write) jFol low any forwarding pointer 

(assign a-temp ;nerge new data with old cdr code 

(merge-cdr b-temp memory-data))) 
(parallel (store-contents a-temp) ;Now write back the new car 
(next-instruct ion) ) ) 

: indirect version of popmem 
(oefucode popmemind 
(start-aenory read) 
(nop) 
(papal lei (tpansoopt) 

(assign vma memory-data) 
(jump popmem) ) ) 

(definst push-constant constant-operand 

(parallel (assign vma (- frame-function macro-unsigned-iamediate D) 
( jump pushmem) ) ) 

(def i nst push- i nd i rec t i nd i rec t-opcrand 
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(parailei {'assfgn vma r- frame-function «acro-un8igned-i««ediate 1)) 

(jump pushmemind)) ) 

(definst pop-indirect (indirect-operand needs-stack) 

(parallel (assign vma (- frame-function ■3cro-un»igned-i«aediat6 1)) 

( jump popmem ind) ) ) 

(deftnst Bovem- indirect (indirect-operand needs-stack) 
(parallel (pushval tcp-of-stack) 

(jump pop-indirect))) ^^___„ — 



;; ; List Processing 

;This is the foriiat-3 version, others uill exist, too- 
(definst car no-operand 

(parallel (check-data- type top-of-etack-a dtp-list dtp-locative dtp-nil) 
(assign voa top-of-stack-a) 
(if (data-type? top-of-stack-a dtp-ni 1) 

(parallel (newtoD quote-nil) (next-instruct ionJ ) 
(goto neutopmem)) ) ) 

;Note that this assumes that the storaae allocator does not allow 

;a 2-ucrd cons to lie across a page boundary. (Or the nC does hair???? ) 

(definst cdr no-operand 
(parailei 

(checR-data-typo top-of-stack-a dtp-Met dtp-locative dtp-ntt) • [1] 

(acsion vma top-of-stack-a) 

(if (data- type? top-of-stack-a dtp-nil) 

(paral let (newtop quote-ni I) (next-instruction)) . [2] 

(sequential 

(start-wenory read) . [2] 

(if (data-type? top-of-stack-a dtp-locative) '[3] 

(parallel (transport) I [4] 

(neutop «emory-data) * 

(next-instruction) ) 
(paral le) 

(transport cdr) . {4] 

sC^an't do this uith temporary ■enory control 
; (incrcment-pma) 

(if (cdr-code? Memory-data cdr-next) 
(paral iel 

(neutop (set-type (1+ v«a) dtp-list)) • [5] 

(next- instruct ion) ) 
(paral let 

(assign vma C1+ vca)) •[5] 

(take-dfspatch))) 
(d) spatch-af ter-next (cdr-code memory-data) 

(icdr-nil) (parallel (neutop quote-nil) ; CG] 

(next- instruct ion))) 
( (cdr-normal) 

;Extra code inserted for temporary memory control 
(start-memory read) ;vma has been incremented 
(nop) 

sEnd extra code 
(paral lei (transport) 

(newtop memoru-data) 
(next- instruct ion) ) ) 
(otherwise (signal-error bad-cdr-code) ))))))) ) 

cycles 

cycles 

cycles 

cycles 

__. .-_. ._. , cycles 

ihjs I? about as fast as it can go without using a A-uau skio. 
which would make all the list cases 5 cycles. ^ *^* 

;This version returns no value. Rather than provide versions that 
:return one or the other of the arguments, we will just let the 
; compiler worry about it. 
(definst rpiaca no-operand ; format 3 

(parallel (check-data-tupe next-on-stack dtp-list dtp-locative) 

(assign vma next-on-stack) 

(jump rplacal) )) 

(defucode rplacal 

(paral let (start-memory read) 

(assign b-temp top-of-stack-a) 
(decrement-stack-pointer) ) 
for-effect (popvaU) ;Adiust stack during memory wait 

(parallel transport write) ;Follow any forwarding pointer 

(assign a-temp sflerge new data with old cdr code 

imcrge-cdr b-temp memory-data))) 
Iparallel (store-contents a-temp) ;Now write back the new car 
(next-instructicn))) 

(definst rpiacd no-operand 

(parol Iel (check-data-type next-on-stack dtp-list dtp-locative) 
(assign vma ncxt-on-stack) 
(if (data-type? next-on-stack dtp-locative) 
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Cgoto rpiacai f 
(drop-through) ) ) 
(p2ra!lei (start-memory read) 

(assign 3-terr.p top-of-atack-a) 
(dccrement-stack-pointtr) ) 
(for-effeot ipopval)) ;Acliust stack during memory uait 

(pa'-ailel (transport cdr) ;Foilow anu forwarding pointer 

;Can't do uith temporary merrcry control 
; i ;ncr£me^t-pm3) ;Acce99 Cdr cell 

(if (cdr^codeV memory-data cdr-normal ) ■ 
( •equen t i a I - _ 

jExtra code inserted for teKporary aertory control 
(assign vna (1-f vaa) ) 

(parallel (Note second cell not transported 

(store-contents a-temp cdr-nil) 
(next- instruct ion) ) 
); extra parenthesis for temporary aemory control (stou RPU) 
(drop-throuchJ ) ) 
; This is the abnoraat case. Trap out to macrocode to allocate a new 
; 2-uord cons cell and forward the old one to it. But first, check 
,; for rp I acd*ing soaething to nil, wnich ua can do* 
(if (not (data-tL;pe? a-temp dtp-nil)) 

(take-DC5t-trap rplacd-escape restore-stack) 
(drop-through) ) 
(assign vma (anem (stack-pointer 1))) iPMA was already changed, restart 
(star t-«effiory read write) 
(nop) 

(parallel (assign ■emery-data (set-cdr eemory-data cdr-nil)) 
(start-memory write) 
(next-instruct ion) ) ) 



F:>1mach>ucode>apray.11sp.94 

;:; -»- flodezLisp; Package: Micro; BaserS; Louercaseryes -«- 
:;: (c) Copyright 13S2, Sy«t30llcs, Inc. 

; Simple array referencing/storing micrccode 



These are written assuming that AS-1 and related instructions 
are known by the compiler to destroy the T03 register. The cases 
where this matters are both rare and easily recognized in the 
f ina I -assembly phase; it doesn't seem worth spending either time 
or hardware to fix this architectural messiness. 

This is written assuming the presence of the mapping prom on the 
input to the R register, so that the index can bo shifted right 
before adding to the base address, when accessing a byte array. 
Removing this from the hardware would e imply make byte arrays one 
cycle slower. 

Note: we depend on the maximum number of bits in an array subscript 
to be 27, This is because when LDB'ing out the word-offset part we 
have to use a fixed byte-size, and when DPB'ing the byte-offset part 
we can't afford to have bits rotated around from the high end come in 
at the bottom (this is because we have to use ROTATE rather than DPS 
due to a conflict for the magic-nucr.ber field when loading BYTE-R. ) 
The limitation to 27 bits is only serious for bit arrays, which can 
be a maximum of IB megabytes long. 

Ue assume that instruction pclsring can set back the stack-pointer. 

I ^3ds storing into a 0-type array do a read pause write rather 
than ;ust a write. This costs one extra cycle, but allows there 
''0 s3E 5n invisible pointer in the array. (In fact, putting an 
irv/iaible pointer there does not work in the A machine, but I 
suspect the PIAR is going to be implemented with invisible pointers 
in the L. ) This also means that u-tist arrays do not need a separate 
dispatch code. 

Get defmicro and all his hosts 

n 

(declare (muzzled t) ; bitches about haulong 
(cond ((not (status feature Imucode)! 
(load *udcl8) 
( toOD whi le hi I) 
(format nil "•{*»<*>«.)" nil)))) 

;nore kludoes for temporary memory control 
(reserve-scratchpad-meKory 2433 2534) 
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(defareg a-memory-data) ;5ave wemory-data here until we have the real 

; "memory control which doesn't require such exquisite timing 
(defareg a-array-base) :Used m 2-D array code 
(defareg a- index-off set) ;,* 

;Ocfine the basics of the array foreat^ see <LnARCH>DATA third page 
;The definitions are in SYSDtr nou. 

;Set up the symbolic names of the field values for dispatching 
(assoc iate-di spatch-cues array-di spatch-f ield «array-dt spatch-codes*) 
(associate-dispatch-cues array-register-dispatch-field *array-regi ster-di spatch-codes*) 
(associate-dispatch-cues array-type-field *array-type-codea»r 

;Ue need symbolic sources for setting up arrau registers 

(def ine-enurr.erated-value-constants *array-regTster-di spatch-codes*) 

(def ine-enumerated-value-ccnstants «array-di spatch-codes*) 

; Hardware simulation 

;Gtveri an array-dispatch-field or- array-register-dispatch-field, 

;generates the 48-reflected byte rotate 

;uhtch will extract the word part of the subscript. 

;ihi3 is only allowed to depend on the low 3 bits of the field, 

;due to PAL pinout limitations. 

(defun array- index-shift-prcin (dispatch) 

tr >th (Icgand 7 oispatch) •(33 34 35 3S 37 e 8) ) ) 
;; New schG»e of things 

;; Subroutines on this page are called to decode an array, except in the 
;; special opt i aired cases which are open-coded. 

;;Decode a l-dimenaionai array. Entered with the array in the vma and b-vma 

;;(it has been type-checked) and the subscript in the top-of-stack 

xregister. Returns witn the foi lowing stored off the end of the stack: 

;: (amem (stack-pointer 1)) Ccr\trol word, as used with array registers 

;; ^ / . . ^,, I^'» encodes the format of array elecents 

;; (amem (stack-pomter 2)) Baee pointer 

;: (anern (stack-pointer 3)^ Upper bound 

;; tOD-of-stack contains the subscript which has tseen adjusted by the 

;; index-offset ?nd lower bound, if any. Thus this is a zero-origin 

;;sub2cript relative to the base pointer. The subscript has been 

;; checked agamst the lower bound if it is non-zero, co that an 

;: unsigned comparison against the upper bound will do all necessary 

;;bounos checking, top-of-stack is not copied into top-of-stack-a. 

;:5ince the state is all stored off the end of the stack, this is 

; ; freelu pel crab le. 

;;See also array-setup-nd, for n-dimensional arrays. 

Hicro to make the source code uore concise 
defmicro array-eetupx (tupe-code) 
Mparaliel 

(assign (array-register-dispatch-f ield (anen (stack-pointer 1))) , tupe-code) 
ireturn))) ' 

(defucode array-setup-ld 
;Fetch first word of array prefix 
(parallel (start-aemory read) 

(assign (anen (stack-pointer 1)) array-register-event-count)) 
(parallel (nop) :Time for memory 

(jump array-eetup-ld-a))) 

;Sim:l3r but initializes the subscript in TOS to zero during free tine 
(defucode array-setup-ld-zero 

;Fetch first'word of array prefix 
(oaraMei (start-mc-mory read) 

(assign (ijmen (stack-pointer 1) ) array-rcgister-event-count) ) 
(parallel (assign top-of-stack (set-type (b-constant 8) dtp-fix)) 
(jump array-setup-ld-a) )) 

;Similar for when stuff has already been fetched from memory 
(defucode arrau-setup-ld-men? 

(parallel (assign (amem (stack-pointer 1)) array-register-event-count) 

I jump array-setup-ld-a)) ) 

(defucode arrau-setup-ld-a 
:£xtract length from header, assuming fast case, and dispatch on kind 
(paraf lei 

(declare-mexory-timing data-cycle) jentcred with cycle in progress 
(transport header) •- w 

(assign a-memory-data memory-data)) ;temporary memory control 
(para I lei =» » 

(assign (an»em (stack-pointer 3)) 

(set-type (array-normal-length-field a-memory-data) dtp-fix)) 
Idiscatch-af ter-next (array-di spatcn-fic Id a-memory-data) 

{ isrray-dfspatch-l-bi t) (array-setupx Sarray-register-dispatch-l-bi t) ) 
( Usrraj-dispatch-Z-bit (array-setuox Xarray-register-d(spatch-2-bi t) ) 
Jarray-dispatch-4-bit array-setupx Xarray-regioter-di spatch-4-bi t) ) 
Uarray-d.9patch-8-toit) (array-setupx Xarray-regi ster-di spatch-8-bi t) ) 
XorraL|-dtsp3tch-lo-bit) (array-setupx Xarray-regi ster-di soatch-16-bi t) ) 
Uarray-dispatch-word) (array-setupx Xarray-regi ster-di spatch-word)) 
( 1 xarray-d i spatch-boo 1 can) (array-setupx Xarray-reg i s ter-d i spatch-boo I ean) ) 
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rt:^3Pray-dr8patch-fe3tfer/ array-setup-wi th-feaderi tShort arrau uith leader 
{< Xarray-di spa tch-5hort- indirect) array-aetup^short- indirect) jfltep laced or indirect 
( (Varra^-di spatch-iong} srray-eetup-) or.gl ;GeneraI long forrn 
(otheruit se is ignal-error unfmpic::iented-or-i I legal -array-type) )T) 
;Set_Da8epointer to word containing first array atenent, assuming fast case 
(parallel tassign (amem (stack-pointer 2)) 

(set-tupe (1+ v«a) dtp-locative)) 
(take-dispotchl) ) 

(defucode array-setup-wi th-leader 
jFind the correct length and base address, dispatch on type 
(assign b-ter.p-2 ; Can't overlap this due to # conflict 

(+ b-vna (array- leader- length-field a-«emory-data) 1)) 

; Above conflict might be fixed bu exploiting the f act (?) 

; — th3t b-vp.a already contains a dtp-iocative tag, eo that 

; wc need onlu set tne high part of the type field. 

• — Uoutd nave to add a new macro for this, 
(parai tei 

lassign (c:^em (stack-pointer 3)) 

(sei-UjpG (array-short-lenqth-f ield a-memory-data) dtp-fix)) 
(diEpatch-3f ter-next (arrau-type-f le Id a-menory-data) 

art-it array-5c+upx xarray-regi ster-di spatch-1-bi t) ) 
Uar t-^D arrau-9«tupx *>iarray-regi ster-di spatch-2-bf t) ) 
U3rt"Vo) (array-setupx larray-regi ster-di spatch-4-bi t) ) 
ar t-o,D 3-t-string) (arrau-set'jpx :;3rrau-regi ster-di spatch-S-bi t) ) 

(tart-icu art-fat-gtrtng) Tarray-setupx t array-reg i ster-di epatch-16-bi t ) ) 

((art-q art-q-liit) (array-setupx Xarrey-regTster-dispatch-word) ) 
((art-boo I eon) (array-setupx Xarray-register-dispatch-boolean) ) 
(otherwise (signal -error unisipleacnted-or-i I legal-arrau-tuoe) ) ) ) 
(parai lei 

(assign (amem (stack-pointer 2)) 

(set-tupe b-temp-2 dtp-locative)) 
(take-dispatchl)) 

(defucode array-setup-short- indirect 
;Error if negative subscript 
(parallel 

(error-if (minus-f ixnuft top-of-stack) illegal-subscript) 

(assign b-temp a-nemory-data) ) -To free up AHUA in cycle after next 

;Get the length ' 

(assign (amen (stack-pointer 3)) 

(set-type (arrau-short-ind!rt»ct-Iength-f teld a-Bemory-data) 
d;p-fix)) 
;Get the index offset and add it in to the subscript and upper bound 
(parallel ;This instruction can't be flushed, t-o-s .ne. t-o-s-a 
(assign a-temp (arrag-short-indtrect-of fset-f ieid b-temo)) 
(assign b-temp obus) I 
(assign (amem (stack-pointer 3)) 

(set-type (+ (amem (stack-pointer 3)) b-temp) dtp-fix)) 
(assign top-of-stack 

(set-type (+ a-temp top-of-stack) dtp-fix)) 
; Advance to second ucrd of prefix (indirect pointer or displace 
^address), and copy first word for dispatch in next cycle 
(parallel " 

(assign b-tefflp-2 a-wemory-data) 
; temporary menory control can't do thre 
: (increment-pma) 



;Fnr testporaru memory control, read second word the slow way 

(assign vma (1+ vma)J " 

(start-iieraory read) 

(nop) 

(assign a-«emory-data merrory-data) ; temporary memory control 

;iJecide whether displaced or indirect, dispatch assuming displaced. 

' Pai c I I e I 

(if (data-type? a-memory-data dtp-locative dtp-fix) 

(parallel (assigr-* (amem (stack-pointer 2)) a-menoru-data) 

(take-oispatch) ) 
(parallel (assign (amem (stack-pointer 2)) a-memory-data) 

,^. ^ ^ ^^ <caM-and-dispatch-upon-return array-setup-ld-indirect))) 

(dispatch-after-next (array-type-f ield b-temp-2) 

Uart-lb) (array-setupx Xarray-register-dispatch-1-bi t)) 
( art-2o array-setupx Xarray-register-dispatch-2-bi t) ) 
( (ar t-Ab) (array-setupx tarray-regi ster-dispatch-4-bi t) ) 
((art-Sb art-string) (array-setupx Xarray-regieter-di spatch-S-bi t) ) 



(defucode array-setup-long 
; Rewrite this code later when temporary memory control is flushed 
:Advance to second word of prefix (indirect pointer /base address) 
(pa?a??H ^'^^* "°^^ ^°'" '****" dispatch, b-temp must be left around for 2d-array. index 

(assign b-temp a-memory-data) 

Stenjporary memory control can't do this 

: (increment-pma) 

;For temporary memoru control, read eccond word the alow uau 
(assign vma (i+ vma)) * 
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(c tart-raeinory read) 
(nop) 

;Decide whether it's indirect pointer or base address and stash It 
ipara I I e I 

(ass-ign (amem (stacR-poi nter 2)) mGmory-data) 
Uf (data-tijpe? uemory-data dtp-locative dtp-fix) 
;In this case there io no index offset 
(seoucnt ia I 

tCct the length the slow way ^ ' 

(assign vma Tl+ vma) ) 

(star t-mencry read) 

(dispatch-af ter-next (arrau-type-f ietd b-temp) 

(art-lb) (array-setupx iarray-regi ster-di spatch-l-bi t) ) 
lart-^b (array-setupx Xarray-regieter-dispatch-2-bi t)) 
I 3rt-4b) (array-setupx Xarray-regi ster-dispatch-A-bi t) ) 
r!"T? 3'"^-3^'"'"g' (arrau-setupx larray-registcp-dispatch-g-bi t) ) 
ir 'n ^rrn'!;l;f^1i"5* larray-sctupx 2array-rcgi8ter-dispatch-16-bit)) 
art-q art-q-l St) (array-setupx larrau-regt ster-di spatch-word) ) 
ua. t-boolean) (array-setupx Xarray-register-dispatch-bootean) ) 
(para??ell ''^^ *« 'Snal-error unimpleaented-or-i Hegal-array-type) ) ) 

tacsien (amem (stack-pointer 3)) ■eraory-data) 
ita^e-ditpatcn) ) ) ^ 

;IndirGct C3£w, with index offset 
(sec:'jert iat 

:_'et the lenqth the slow way 
tatsign vra u* vma) ) 
(start-iewory read) 
; Error if negative subscript 

(error-if (ninus-f ixnum top-of-stack) illegal-subscript) 
(assign b-tenip-2 nemory-data) 

;Get the index offset •nd add it In to the subscript and upper bound 
(assign vma (1+ vaa) ) 
(start -memory read) 
(nop) 

(assign a-ireniory-data tiemory-data) 
(assign (aKien (stack-pointer 3)} 

(set-type (+ a-memory-data b-temp-2) dtp-fix)) 
(disoatch-af ter-next (array-type-field b-temp) 

((art-lb) (array-setupx -3rray-register-dispatch-l-bi t) ) 
( art-^b) (array-setupx larray-register-dispatch-Z-bi t) ) 
(art-Mb) (array-setupx ^array-regi ster-di spa tch-4-b i t)) 
art-Sb art-string) (arrsu-setupx Xarrau-register-dispatch-S-bi t) ) 
art-16b art-fat-string) (array-setupx Sarray-register-dispatch-lB-bi t)) 
art-q art-q-l ist) (array-setupx Xarrau-regi ster-di spatch-word) ) 
jiart-booiean) (array-setupx Xarray-register-dispatch-boolean) ) 
totherwiso (signal-error uniitplementcd-or-i I leaal-arrau-tuoe) ) ) 
(pcral lei » w wr 

(assign top-of-stack 

(set-tupa (+ a-«etrory-data top-of-stack) dtp-fix)) 
leal l-and-dispatch-upon-return array-setup-ld-indirect) ) ) ) ) ) 

:ThJe is a modified version of the above (array-setup-ld-a) which handles the 

; recur Si on into a short- indirect array, Ue only want the corrected 

;base address and any associated index offset. 

;The A-machine sometimes checks the length of the two arrays 

tacamst each other; we will never do that and assume things 

;were correctly set up by make-array, and that no one adjusts 

;the size of an ind tree ted- to array downward. Tha check is 

;very difficult when the array types differ. 

(de f ucoae arr ay-se tun-ld- i nd \ rect 

(parallel (check-arg-tupe array (amem (stack-pointer 2)) dtp-arrau) 
(assign vma (amera (stack-pointer 2))) 
(assign b-vma (amem (stack-pointer 2)))) 
;Fetch first word of array prefix 
(parallel (start-meir.ory read) 

^ (assign (amem (stack-pointer 1)) array-register-event-count)) 
^^9'^' ^ :Ti«e for memory 

;Dispatch on kind 
(pora! •* t 

(transDort header) 

(assign a-memcry-data menory.data) ; temporary memoru control 

(dispatch-after-next (array-di spatch-f leld memory-data) 
iUarray-dispatch-1-bi t Xarray-di spatch-2-bi t 2array-di( 




md 

* ^ . - , - array 

;Mdjust base address 

(assign b-ten:p-2 :Can't overlap this due to tf conflict 
. (+ b-vma (array- leader-length-field a-meaoru-data) D) 
tpara Mel 

lassign (amem (stack-pointer 2)) 

(set-type b-temp-2 dtp-locative)) 
(return) ) ) 

((tarray-dispatch-short-indirect) ;Di8placed op indirect 
;Error tf neoative subscript 
(parallel 

(error-if (ninus-f ixnum top-of-stack) illegal-subscript) 
.rif^thriSH?"'^:^ a-memory-data)) ;To free up ATWA in next cycle 

:Get the index offset and add it in to th« subscript and upper bound 
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iparaffer 

(assign a-tewp (array-short-indirect-of ftet-f ield b-temp-2}) 

(assign b-terrp-2 obus) ) 
(assign (anem (stack-pointer 3)? 

(set-type (+ (amem (stack-pointer 3)) b-teBip-2) dtp-fix)) 
(para I le! 

(assicjr^ top-of -stack (set-type (+ a-temp top-of-»tack) dtp-fix)) 

: tenporary memory control can't do this 

: ( incpcment-pma) 

:For tcrporaru memory control, read second word the alou uay 
(assign vma (i+ vma)! 
(start-memory read) 
(nop) 
,;Dccide whether displaced or indirect, 
(para! let 

(assign a-memory-data aemory-data) jtempopary aenorg control 
(if (data-tyoe? memory-data dtp-locative dtp-fix) 

(paraliei (assign (a&em istackrpointer 2) ) a-aenory-data) 

(return) ) 
(parallel (assign (amefs (stack-pointer 2)) a-aemory-data) 

(jump array-setup-ld- indirect) ) ))) ; Indirect, loop 
( (•array-di*patch-iong tarray-aispatch-Jong-fflul tidiwiensional) ;beneral long form 
tNcte that ue don't care hou msny dimensions the indirected-to array has. 
;Reu!rite this code later when temporary memory control is flushed 
lAova-.ce to second uord of prefix (indirect pointer/base address) 
; temporary mer:ory control can't do this 
; ( increment- pr.a) 

;For temporaru meiroru control, read second word tne slow way 

(assinn vna (1+ vma)> 

(start-memory read) 

(nop) 

tOecids whether it*t indirect pointer or base address and stash it 

(parai lei 

(assign (amem (stack-pointer 2) ) memory-data) 
(if (data- type? cemory-data dtp- locative dtp-fix) 
;In this case there is no index offset 
(sequential 
jGet the length the stew way 
(assign vma u-f vma) ) 
(start-memory read) 
(ncp) 
(paraUel 

(assign (amen (stack-pointer 3)) memory-data) 
(return) j ) 
; Indirect case, with index offset 
(sequential 
stiet the lenath the slow way 
(assign vma Tl+ vna)) 
(start-memory read) 
;Error if neaative subscript 

(error- i f (minus- f ixnum tcp-of -stack) i I legal -subscript) 
(assifjn b-tefr.p-2 memory-data) 

;Get tne index offset and add it in to the eubscript and upper bound 
(assign vma (1+ vma)) 
(start-memory read) 
(nop) 

(assign a-memory-data memory-data) 
(assign (amen (stack-pointer 3)) 

(set-type (+ a-nemory-data b-temp-2) dtp-fix)) 
(parallel 

(assign top-of-stack 

(cet-type (+ a-mcmoru-data top-of-stack) dtp-fix)) 
( juffip array-setup-ld- indirect)) )))) 
(otherwise (signal -error unimplemented-or-i t leoal-array-type) ) ) ) 
;5et basepotnter to word containing first array element, assuming fast case 
(parallel (assign (amem (stack-pointer 2)) w » 

(set-type (1+ vma) dtp-locative)) 
(take-dispatchJ)) 

:Set up an array leader as a ■Q* array. If no leader, make it zero 

;long since some things call this to test for the presence of a leader. 

;Thm5s that really want a leader will then get an error. 

: tcp-of-stack is not touched, sines indirection and offset don't 

;af:pU! to leaders. 

(defucode arrau-setuD- leader 

;Fet:;h first'word of array prefix 
(parallel tctart-memory read) 

(assign (amen (stack-pointer 1)) array-register-event-count)) 
:Set vp type as Q 
(assign (array-register-dispatch-field (amen (stack-pointer 1))) 

tarray-regi ster-di spatch-word) 
jDi snatch on kind 
(parallel 

(transport header) 
(ass ion b-temp memory-data) 

; Initialize length to zero, assuming no leader is present 
assfon (amem (stack-pointer 3)) (set-type (b-constant 3) dtp-fix)) 



(d'snatch-after-next (arrau-di spatch-f ield memory-data) 
((iarray-dispatch-l-pit Xarray-dispatch-2-bi t 2array-di 
*ar ray-d I spa tch-S-b i t *array-d i spa tch-lS-b i t Xar ray-d 



„ i«patch-4-bi t 
Xarray-dispatch-word 
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iarrsy-citspatch-bcoicani (return}) ?Appays of the first kind 

(Uarrau-dtspatch-leadep) ;Short arrag with ieader 

(paraile! * 

(assign (amem (stack-pointer 3)) 
' (set-type (array- Icaaer-length-f ie»d b-te»p) dtp-fix)} 

(reiurn) ) ) 

((itarpay-disoatch-short-indirect larray-dispatch-shopt-2d) (return) 
I Usrray-d i spatcn- I ong Xarray-d i spatch- 1 ong-mu 1 1 i d i wens i ona I ) 



) ;no leader 



(assign (anew (stack-pointer 3)) ;Lonq array, nay have leader 

(set-type (array- long- leader- length-f leld b-temp) dtp-fix)) 
(para Me \ "^ ^^ 

(assign (amem (stack-pointer 2)) 

(r r i)?®*"*^'^^® ** ^"^ (array-long-pref tx-Icngth-field b-temp)) dtp-fix)) 

(otherwise .(si gnat -error unimp I emented-or-i Mega I -array-type) ) 
I ! .^f f'^9'"^?'' ^° ^^^^ containing first leader element, aesuatn^ 



)))) 
i^ct cdBcpomxer to word containing first leader element, aesuatng fast case 

(psroilel (assign (amem (stack-pointer 2)) 

(set ' ** 

(take-dispat 



(set-type (1+ vma) dtp- locative) ) 
— itchTT) 



i^^i^l^nf? K^J^^- ^' *'* '* "^"""^ 1-dimensional, no aatter how Bany distensions 

,11 reaiiy nas 

(oefucorii'e ^rra.j-setup-f orce-ld 

; Fetch first i;crd of arrey prefix 

(poraiiei (start-fnenory read) 

f-..i (assign (amem (stack-pointer 1)) array-register-event-count)) 

T-'^^ ; t lire for memory 

(La-aiiel *''^^'' ^'"°"' ^^^der, assuming fast case, and dispatch on kind 

(declare-Bemcry-tiaing data-cycle) centered with cycle in progress 
(transport header) 

(assign a-meaory-data aerory-data) ) t teaporaru aeaory control 
(parallel 

(assign (aacm (stack-pointer 3)) 

(set-type (array-nor«a!-length-f ield a-aemoru-data) dtp-fix)) 
idi soatch-af ter-next (array-d i spatch-f ield a-aerrcru-dsta) 

( (!£array-di8patch-l-Di t) (erray-ootupx Xarray-register-dispatch-l-bi t) ) 
K (Xarray-dicpatch-2-fr i t) (array-selupx Xarray-register-diepatch-2-bi t) ) 




( (iarray-dispatcn-word) (array-setuox torray-register-dispatch-uord) ) 
( (Xarray-d i spatch-bco t ean) (array-setupx Xarrau-r eg i ster-d i spatch-boo I ean) ) 
(iXarraij-d I spatch- leader) array-cetup-wi th-leader) ;Short array with leader 
UXarray-dtspatch-chor t-indirect) array-setup-short-indirect) ;Displaced or indire" 
J uarr ay-d i spatch- 1 org Xarray-d i spatch- i ong-mu 1 1 i d i aens i ona I ) arrau-sotup- 1 ono) 
((Xarr$y-dispatch-6hort-2d) 3rrcy-setup-6r.ort-2d-as-ld) » i- w 

(otherwise (signal-error uninplerented-or-i 1 legat-array-type) ) ) ) 

;Set basepomter to word containing first array eleaent, assuming fast case 

(parallel (assign (amem (stack-pointsr 2) ) 

(eel-type (1+ vbs) dtp-locative)) 
<take-di spatch))) 

(defucode array-setup-8hort-2d-as-ld 
:: Must ccfppute length by multiplication 
(assign b-tecp (array-coTumns-f ield a-cemory-data) ) 
(write-apy-x b-temp unsianed) 

^assign b-temp (dpb a-memory-data 9 IG. 8)) tarray-rows-f ield in left half 
(urite-npy-y-from-high b-temp unsigned) 
(dispatch-af ter-next (array-type-f teld a-aemory-data) 
J (art-lb) (array-setupx tarray-regi ster-dispatch-1-bi t) ) 
}}art-2b/ (array-setupx Xarray-reaister-dispatcrh-2-bi t)) 
Uart-Ab) (array-aetupx Xarrau-regi ster-dispatch-4-bi t) ) 
((art-2b art-string) (array-setupx Xarrau-register-dispatch-8-bi t) ) 

-5y-s3tupx Sarray-regi ster-d ispatch-lG-b it)) 
ispatch-word) ) 
:h-boolcan)) 

lotneruise isignai-error unimpleaented-cr-i I legal-arrau-tuDe) ) ) 
(pa*"al lei .* ■ »r- 

(assign (amer (stack-pointer 3)) (set-type apy-product dtp-fix)) 
(take-dispatch) ) ) 

;; ; l-diaens i ona I array-accessing instructions 

jForaat 3: Array and subscript on the -stack 
(defmst ar-1 (no-operand needs-stack) 
;F»ret step is to check operand types and fetch array header 
iparailei checV-arg-type array ncxt-on-stack dtp-arrag) 

(assign vaa next-on-stack) 
. . (assign b-vma next-on-etack) ) 
(parallel (start-aeaory read) 

(check-aro-tyoe subscript top-of-stack-a dtp-fix) 
(jump ar-I-coamon) J ) 

'(Ho^T^ItH V^y °!] the stack, subscript as unsigned immediate argument 
Idennst ar-l-maed unstgned-tamediate-operand oryurneni 

inir^!i!?*^7.K!J°.^^***' operand types and fetch array header 
(parallel check-arg-type array top-of-stack-a dtp-aFrau) 

(assign vaa top-of-stack-a) ^ 

(assign b-vaa top-of-stack-a)) 
(parallel (start-aerpory read) 
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fpushval «acro-un9ianed-iB!r!ediate} 
(jump ar-l-co«aon))i 

;Fop»at 2: Array on the stack, »ubBCPipt in local variable 
(definst ar-1- local address-operand 
•First step is to check operand types and fetch array header 
tparatiel icheck-arg-typc array top-of-stack-a dtp-array) 
(assign vna top-of-stack-a) 
(assign b-vma top-of-stacK-al J 
{paralfet (start-Bencry read) 

(check-arg-typo subscript address-operand dtp-fix) 
(pushvai address-operand) 
(jump ar-1-common) ) ) 

;Thts Micro is used inside the dispatch table befou. Hust ba defined 
;first due to 1-pass microcompi ler. 

(defBtcro ar-1-ucode (byte-size ioptionat boolean-hack (bounds *a-tefflp)) 
' (array-ucode-read « byte-size tbootean-hack top-of-stack .bounds popZpush)) 

;This i9 the version for the siou case 

(defeicro ar-l-hair (byte-size ^optional boolean-hack (bounds * (aacB (stack-pointer 3)))) 
* (array-ucode-read , byte-size , boo lean-hack top-of-stack .bounds popZpush)) 

;nicrocode shared with array registers, see befou 

(deforcro array-ucode-read Tbyte-size boolean-hack index bounds result) 
'(sequential 
;Run the seniory, start read, check bounds 
(parallel 
(start-ff«»nory read) 
,B(and bounds 

* ((check- fixnum-b , index) ; Error if bad 

(error-if ( iesser-or-equal-f ixnun-unsigned .bounds .index) 
i I legal-subscript) ))) 
;Sct up byte-r register from lou bits of index 
.vif (eq Dyte-sizc *Uord) *(nop) 
• (assign byte-r 

(- (a-constant 48) 

(rotate .index ,(1- (haulong byte-size))) 

s (dpb .index tbyta source 

; ,(-6 (haulong byte-size)) ;ss 

; ,(1- (haulong byte-size)) ;pp 

; d) sno serge 

;Extract answer and return it as result of instruction 
,(If (not boolean-hack) 

'(pacatlel (transport data) ;E^Brt if byte, in case of MAR invz 
(.resul t 

,(if (eq byte-size 'Uord) 
*meR!ory-dat3 

'(set-type (Idb memory-data .byte-size byte-r) 
dtp.fix))) 
(next-instruction)) ^ - 

Mif (Idb-bi t-test memory-data byte-r) 

(parallel (.result quote-t) (next-instruction)) 
(parallel (,resul t quote-nt I ) (next-instruction)))))) 

:Cofrmon Btcrocode for all AR-1 instructions 

;nefflory is reading array header, top-of-stack register has subscript. 

;lNeird hacks: 

;Tnere are tuo arguments on the stack (in some cases one uas put there bogus I y 

; and must be popped off again if ue pclsr out). 

;array-masK-6ht f t-prom is a function of current dispatch 

; and gives the proper left rotation to extract the ucrd part 

; of the index. 

;lhc byte length for the word part of the index is 27. This 

; wakes the maxinum array size 1/2 of virtual Bemory, which is plenty. 

(defucode ar-1-common 

(parallel jnopi tlime for Bemory cycle 

(doclare-memcry-timing acti ve-cuc le) ) 
;Extract length from header, assuming fast case 

3600 Microcode 19 Traps 



The machine also provides several special-case dispatches, which were added to spttd up 
various critical operatioas. The dispatch-atter-next micro recognizes these automatically; 
they need not be programmed sptcizlly. When one of the special-case fields of the Abus is 
dispatched upon, the byte-extraction hardware is left free, allowing a different byte to be 
operated on simultaneously, or avoiding the usurpation of microinstruction fields used to 
control both byte extraction and other things. See the hardware documentation for a list 
of the special-case fields. 
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take-dispatch Micro 

dispatch-after-next only takes effect if take-dispatch is executed in the following 
- cycle. In the hardware, dispatching works by storing the address of the selected clause in 
the NPC register, and take-dispatch means to take the next microinstruction from the 
address in the NPC. 

long-dispatch address Micro 

Jump to the control-memory address given by the low 14 bits of the datum, address. The 
address is stored in the NPC register and the jump only happens if take-dispatch is used 
in the following cycle, long-dispatch allows dispatches on more than 4 bits to be done, 
although usually more slowly. Currently the dispatch clauses must be defined with 
defucode-at-loc. 



5.4 Traps 

trap-if predicate true Micro 

If predicate is true, take the next microinstruction from true\ otherwise take the next 
microinstruction normally (either from the normal successor or under the control of any 
other fiow-of-control micros done in parallel). The true clause is exactly like an if clause 
(of course (drop-through) is almost useless here). 

The difference between trap-lf and If is threefold: It is legal to do trap-if in parallel 
with other flow-of-control micros, most commonly next-instruction. If the predicate is 
true, the side-effects of the current microinstruction are suppressed. If the trap is taken, 
the current microinstruction takes twice as long to execute as it normally would. 



A very important thing to note is that trapping pushes the NPC register onto the 
microcode subroutine stack. Thus trat>-it is not equivalent to an If and a goto. The trap 
handler should either discard the saved NPC by using the trap-no-save micro, or use the 
trap-save micro to save the rest of the machine state (the CPC), in which case the 
trap-restore micro may be used to retry the trapped microinstruction. 

Traps are used to program exception cases while allowing the normal case to run at 
maximum speed, with no overhead for checking for the exception. 

;Oispatch to appropriatB accessing routine 
(para 1 1 e I ( transpop t header ) 

(assign a-tewp (arpay-normal- length-field «e»ory-data)) 
(assign byte-r array- inoex-ch i ft-prom) 
idispatch-af ter-next (array-dispatch-field Bcaory-data) 
((Xapray-dispatch-l-bi t) (ap-l-ucods 1) ) 
((S3rray-dispatch-2-bi t) (ar-1-ucode 2)) 
l{l3rpay-disnatch-4-bi t) <?!P-l-ucods 4)) 
((Xarray-aispatch-S-bt t) (ar-1-ucode 8)) 
(Ciarray-dispatch-lB-bi t) (ar-l-ucods IG,)) 
( (larray-dispatch-uorci) iar-1-ucode Uord)) 
( CXarpay-dicpatch-booiean) (ar-l-ucode 1 t)) 
( (Xarpay-dispatch- leader) (ooto ar-l-wi th- leader)) 

( iAarray-disp3tch-short-tndlrect) (goto ar-l-haip)) :all others 

( (iarray-dispatch-long) (goto ar-l-haip)) 

(otherwise (signal-erpor unimplemented-or-i I legal -array- type) ) ) ) 
;Set VMA to uord containing array elcnient, assuming fast case, 
;but leave B-VHA pointing to the original array header, 
(parallel (assign vwa (+ vraa (idb top-of-stack 27. bute-r) 1)) 
(take-dispatch)) J 

;AR-1 of a sh^rt l-dt«ens ionat array that has a leader. 
;3 cycles slower than fast case 
(defucode ar-l-wi th-leader 

:For temporary Bemory control, "ust retrieved goddaan •enory data 

; which there weren't the data paths to save earlier 

(assign vaa b-vma) 

(start-«emory read) 

(nop) 

(assirm a-»emcry-data aemory-data) 

;Potnt vma at the first data word in the array 

(assign voa a-memory-oata) ;Kludqe for tetrporary nereory control (field overlap) 

(assign vma (+ (array-leadsr-length-f ield vfiia) b-vna 1)J 
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;Di5patch on the array tl^pe ftefci 

(paral)ttl (assign a-tecp (array-short- length-field a-aemopy-data) ) 
(assign Dyte-r array- i ncJex-shi ft-prom) 
(dispatch-after-next (array-type-field a-«emory-data) 

((a'-t-lb) (ar-1-ucode 1)> 

((art-2t5) (ar-1-ucode 2)) 

((art-4b) (ar-1-ucode 4)) 

((art-So art-string) (ar-l-ucode 8)) 

{(3rt-16b art-fat-string) (ar-1-ucode IS.)) 

((art-q art-q-tist) (ar-1-ucode Uord)) 

((art-boolean) (ar-1-ucode 1 t)) 

(otherul se (signal -error uniftplemented-or-i I legal -array-type) ) ) ) 
tPoint vwa at the addressed data word 

(parallel (assign vna (+ vaa (Idb top-of-stack 27. byte-r))) 
(take-dispatch))) 

;Hairier cases of AR-1. 
(defucode ar-1-hair 

(parallel (assign vna b-vma) ;Frnd out everything about this array 

(cal i-and-return-to array-setup-ld ar-1-hair-a))) 

(defuccde ar-l-hair-a 
tppraf lei 

(assign byte-r array- index-shi ft-prom) 
(dispatch-after-next 

(array-register -dispatch-field {aaen letack-pointcr 1))) 



( {«array-reg 
( (tarray-reg 
{ (Xarray-reg 
f Ciarray-rcg 
{ (larray-reg 
( (XarrCLi-reg 
f (*arr 



ster-dispatch-l-bi tl (ar-1-hair D) 
ster-di6patch-2-btt) (ar-l-hair 2)) 
ster-dispatch-4-bi t) (ar-l-hair 4) ) 
ster-dispatch-8-bitJ (ar-l-hair 8)) 
ster-disoatch-lS-bi t) (ar-l-hair IG.)) 
WW-, ^y.ster-dispatch-word) (ar-l-hair Uord)) 
ay-reoistcr-dispatch-boolean) (ar-l-hair 1 t)) 
(otherwise Tsignai -error uniapleBented-or-i 1 1 ega I -array-type) )) ) 
tSet the Y11A 
(parallel 

(assign vma (+ (anem (stack-pointer 2)) (Idb top-of-etack 27, byte-r))) 
(take-dispatch))) 
;l-dia:cnsional array-etor tng instructions 

; Format 3: Value, array, Bnd subscript on the stack 
(definst as-l (no-operand needs-stack smashes-stack) 
:Firct step is to check operand type's and fetch array header 
(parallel (check-arg-type array nexi-cn-stack dtp-arrayi 
(ass i en vma ncxt-on-stack) 
(assign b-vma next-on-stack)) 
(parallel-'(start-iiemory read) 

(check-arg-type subscript top-of-stack-a dtp-fix) 
(jump as-I-coromon) ) ) 

;Forr:?t 1: Value and array on the stack, subscript as unsigned iamodiate 
(def inst asi-l-iiiimcd (unslgned-iiimediate-cperand smashes-stack) 
;Ftrst step is to chcck"operand types and fetch array header 
(parallel (check-arg-tupe array tcp-of-stGck-a dtp-array) 
(assign vaa top-of-stack-a) 
(assign b-vma top-of-stack-a)) 
(parallel (start-memory read) 

(pushva I nacr o-uns i gned- i miacd i ate) 
(jump as-l-conmon))) 

;For»at 2: Value and array on the stack, subscript in local variable 
(def inst as-1-locaI (address-operand swashes-stack) 
;First step is to check operand types and fetch array header 
(parallel icheck-arg-tupe array top-of-stack-a dtp-array) 
(assign vna top-of-stack-a) 
(assign b-vma top-of-stack-a)) 
(parallel (start-aemory read) 

(check-arg-type subscript addraes-operand dtp-fix) 
(pushva I address-operand) 
(jump as-1-common) ) ) 

;This micro is used inside the dispatch table beiisu. Must be defined 

;first due to 1-pass microcotnpi ler, 

;Note that since there are three values on the stack and 

;ue don't return any values the stack-pointer gets decremented three tiaes, 
(defmicro as-l-ucode (byte-size ^optional boolean-hack (bounds *a-teap)) 
* (parat lei 

(decrement-stack-pointer) 

(array-ucode-wr i te , byte-size .boolean-hack top-of-etack 

.bounds next-on-stack)}) ;aftcr stack-pointer decremented 

This is the version for the slow case 

This biter has to know that bounds checking in array-ucoda-wr i te 

happens in the first microcycle, hence «B£FORE« the 

.— decrement-stack-pointer that is done in parallel. 

(defmicro as-l-hsir (byte-size ioptionat boolean-hack (bounds ' (aaea (stack-pointer 3)))) 
' (para! let 

Idecrement-s tack-pointer) 

(arrsy-ucode-wr i te .byte-size .boolean-hack top-of-stack 
.bounds next-on-stack))) •.. 



4,887,235 
571 572 



:Corrrrcn fflicrocode with array regiaters, see below 
Icefptcro array-ucode-uri te (byte-size boolean-hac 



ter 



Ms-ouential^ ' (byte-size boolean-hack index bounds value) 

:wo?J^^^I!!f'"?n^W"!r*K'""^ °f 1:'°'"'^ ^° ^^ *^°^«^ '"^o* check bounds and subscript type 
:No:te: pape fault can happen later, when urite-data stored ^ 

i '^f? } c*^^'^*^ urite-access her a due to conflict for spec field 

(start-memory read) 
,a{and bounds 

' {(check- ft xnum-b .index) xError if bad 

(error-if < I esser-or-equal-f ixnus-unsigned .bounds .index) 
I i legal-subscript)))) 
(para! lei 

:G5t value to be stored into b-temp if numeric, a-temp if poin 

;fJcxt line commented cut, see "Okay, I give in' below. 

;tac3fgn ,(if (eq byte-size 'Word) 'a-temp 'b-temp) .value) 

(assrgn b-temp .value) 

; Type-check value if byte array 

.(it (and (neq byte-size 'Uordf (not boolean-hack)) 

(cner.k-arg-tijpe .value dto-fix)) 
;lf boolean arrey. take extra cycle to get desired store data 
, ( I f boolean-hock 

Mif (data-type? .value dtp-nil) 

(assign b-temp (b-constant 0)) 
(assign b-temp (b-constant 1)))) 
;bet up byte-r register from low bits of index 
,(if tneq byte-size *Uord) 
' (assign byte-r 

(rotate .index .(1- (haulong byte-size))) 

;(dpb .index .pyte source 

; . (- b (haulong byte-size)) ;63 

; ,(1- (haulong byte-size)) ;pp 

I J °' :no iierge 

(dccrement-s tack-pointer)) 
•(rr?°,^7-''l'/7^° "^'"d --ead fro-n mPfflory and write it back. 
Msequential 

;0K8y. I give in. Take an extra cycle. This allows transporting 
tin order to «ake it possible to set the MAR in an array, and also 
JMj^es '^ possible to preserve the cdr-code, for art-q-iist arrays. 
; irc ABUS to cdr-ccde feature could be used to preserve the cdr-code 
; f or arrays tnat ar^ known not to be in A-ae»oru) 
;— - Maybe consider changing thvs back? 

; — flayoe an extra dispatcn code wnich HARs an entire arrag? 
{parallel (transport write) 

(assign a-tenp (aerge-cdr b-teep aemoru-data))) 
(store-contents a-tecp)) 
'(assign aemory-data 

(■erge-cdr (set -type id;:b b-temp 

, byte-size 
byte-r 
ueniory-data) 
dtp-fix) 
remory-data))) 
(start-aemory write) 
(decrenent-s tack-pointer) 
(next-instruction)))) 

;Coiimon processing for AS-1. 

;Value, array, and subscript on the stack, array header being fetched. 

(defucode as-i -common ^ 

(parallel (nop) -Tiae for aeaoru cycle 

(declare-memory-tiamg active-cycle)) 
{Extract length froa header, assuming fast case 
;Di6patch to appropr-iate storing routine 
(parallel (transport header) 

(assign a- temp (array-normal-length-f ieid aemory-data) ) 
(assign byte-r array- i ndex-sh i ft-proa) 
(dispatch-after-next (array-di soatch-f ield aettoru-data) 
(darray-dispatch-l-bit) (as-1-ucode 1)) 
((%array-di8patch-2-bt t) (as-1-ucode 2)) 
( (*array-dispatch-4-bit) (as-l-ucode 4)) 
((X3rray-disp3tch-8-bi t) (as-l-ucode S) ) 
((Xarray-cispatch-lS-bi t) C^s-l-ucode IG.)) 
(darray-dispatch-word) tas-l-ucode Word)) 
((Xarray-dispatch-booiean) (as-l-ucode 1 t)) 
UXarray-dispatch- leader) (coto as-l-wi th- leader)) 

aarray-dispatch-fihort-indirect) (goto as-1 -hair)) ;all others 
((Xarray-dtspatch-long) (goto as-1-hair)) 
e * v/MA X (o*^^e'""'8e. (signal-error unifiplenented-or-i I legal-arrau-tupe) ) ) ) 
;5et VHA to word containing array ele'r'ent, assuaing fast case, 
;but leave B-VnA pointing at the original array header, 
(parallel (assign vma (+ vma (Idb top-of-stack 27. bute-r) 1)) 
(taKe-dispatch))) 

;AS-1 of a short l-di«ensional array that has a leader. 
:3 cycles slower than fast case 
(dejfucode as-l-wi th-leader 

;For temporary memory control, aust retrieved goddaan aemory data 

: which there weren't the data paths to save earlier 
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iassign vma b-vmaf 
(ata'-t-mcoiopy read) 

<ncp) > 

(assign a-«iemory-data Befflory-data) 
;Point vBia at the first data uord in the array 

(assign vma a-fnemory-data) ;Kludge for temporary Memory control (field overlap) 
(assign v.Tia (+ (array-!cader-length-f ield vma) D-vma 1)1 
:Dispatch on the array type field 

(parallel (assign a-temp (array-short-length-f ield a-memory-data) ) 
(assign byte-r array- index-shi ft-prom) 
(dispatch-af tcr-next (array- type-f]« id m-meaoru-data) 

((art-it>) (as-l-ucode 1); 

((art-2til (as-1-ucode 2)) 

Hart~Ah) (as-l-ucode 4)) 

((art-Sb art-string) (as-1-ucode S)) 

((art-ieb art-fat-8tring) (as-1-ucode IS.)) 

((art-q art-q-tist) (as-1-ucode Uord)) 

((art-boolean) (as-1-ucods It)) 

(other ui&a (signal -error unimpleaented-or-t I legal-arrag-type)))) 
;Pornt VHA at the addrcsced data uorJ 

(parallel (assign vma (+ vma (Idb top-of-etack 27. byte-r))) 
(take-dtepatch))) 

;Ha»rier ca^es of AS-1 . 
(defucode ao-l-hair 



(parallel (assign vma b-vma) :F»nd cut everything about this array 

(catl-and-return-to array-setup-ld as-1-hatr-a))) 

ucode as-1-hair-a 

araiiet 

(assign oyte-r array- i ndex-ah i ft-pron) 

(diEpatch-af ter-next 




-_ ..igna 

;oet the VHA 
(paral lei 



rdl I e 1 

(assign vma (+ (amem (etack-pointer 2)) 

/♦-L w- . uifl*^^ top-of-etacK 27. byte-r))) 
(take-dispatch))) " 



-dispa ^^ 

;;; Array leaders 

I Format 1: Array on the stack, tubccrtpt as unsigned immediate argument 
(definst array-leader- immed unsigned-irtmediate-eperand 
(parallel (check-arg-tupe array tep-of-stack-a dtp-array) 
(assign vma top-of-«tack-r,) 
(assign b-vma top-of-etacK-a) 
(call array-setup-leader) ) 
(assign vma (+ tamem (stack-pointer 2)) macro-unsigned-immcdiste) ) 
(arriy-ucode-read Word ni i macro-unsinned- immediate 
(amem (stack-pointer 3)) ncutop)) 

:For!i!3t 3: Array and subscript on the stack 
(definst array-Trader Ino-operand neods-stack) 

(parallel (check-arg-type array next-on-»tack dtp-array) 
(assign vma nftxt-on-stack) 
(•ssirin b-vna next-on-stack) 
(call array-setup- leader) ) 
(assign vma (+ (a-Tjem (stack-pointer 2)) top-of-stack) ) 
(array-ucode-read Uord nit top-of-stack (aoem (stack-pointer 3)) pop2push)) 

:Format 3: Value, array, and subscript on the stack 
(definst store-array-leader (no-operand needs-stack smashes-stack) 
(parallel (check-arg-type array next-on-stack dtp-array) 
(assign vma next-on-stack) 
(assign b-vma next-on-stack) 
(cat t array-setup-leader) ) 
(paral lei (decrement-stack-pointer) 

(assign vma (+ (amem (stack-pointer 2)) top-of-stack))) 
(array-ucode-wri te Uord ni ( top-of-stack (acem (stack-pointer 4)) next-on-stack)) 

jFormat 1: Value and array on the stack, subscript as unsigned immediate 
(definst store-array-leader-immed (unsigned- immediate-operand smashes-stack) 
iparallel (check-arg-type array top-of-stack-a dtp-array) 
(assign vma tcp-of-stack-a) 
(assign b-v9ia top-of-stack-a) 
(call arra'j-se tup- leader)) 
(assign vma (+ (amem (stack-pointer 2)) macro-unsigned- immediate)) 
(array-ucode-wri te Uord nit macro-unsigned- immediate 

__ (amem (stack-pointer 3)) next-on-stack)) 

j;; Accessing of arbitrary arrays as if they were 1-dimensional , and ALOC 

(definst 21d-aref (no-operand needs-stack) 
;rir8t step is to check operand types and fetch array header 
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(paraMei (check-arg-type array next-on-BtacK dtp-array) 
(assign vna nQxt-on-ctacK.) 
(assign b-vma next-on-stsck) 
(caM-and-return-to array-satup-forca-ld ar-l-hair-a) ) ) 

(de^inst tld-aset (no-operand needs-stack smashes-stack) 
(parallel (cr.eck-arg-type array next-on-»tack dtp-array) 
(assign vma next-on-stack) 
(assign b-vma next-on-stack) 
(cal l-and-return-to array-setup-force-ld as-1-hatr-a) ) ) 

(definst Sld-aloc (no-operand needs-stack) 
(parallel (check-arg-type array next-on-»tack dtp-array) 
(assign vma next-on-stack) 
(assign b-vaa next-on-«tack) 
(cal l-and-return-to array-setup-force-ld ap-1-hair-a) ) ) 

(definst ap-1 (no-operand needs-stack) 
(parallel (check-arg-type array next-on-stack dtp-array) 
(assign vna next-on-stack) 
(assign b-v«a next-on-stack) 
(calt-and-return-to array-setup-ld ap-1-hair-a))) 

(definst ap- leader (no-operand needs-stack) 

(parallel (check-arg-type array next-on-stack dtp-array) 
(assign vma next-on-stack) 
(assign b-vma next-on-stack) 
(cal l-and-return-to array-setup- I sader ap-l-ha»r-a) )) 

(defucode ap-l-hai r-a 

(if (equal-fixnuw (array-register-dispatch-field (aaea (stack-pointer 1))) 

5iarray-regi8ter-dicpatch-word) 
(para I let 

(nex^-ynStrSctlon?? ^* ^*"" (stack-pointer 2)) top-of-stack) dtp-locative)) 

(s i gna I -error locat i ve-to-no n-u ord- arra y) ) ) 

; Decoding 2-di(ienaional arrays " 

Sase as array-setup-ld except (ameni (stack-pointer 3)) gets the width 
and (asen (stack-pointer 4i) gets the height 

(defucode array-setup-2d 
;Fetch first word of arrag prefix 
(parallel (start-nsmory r*ead) 

(assign (aoicis (stack-pointer 1)) array-rcgister-event-count)) 
(nop) ;Time for remory 
;Copy header because of temporary tiemoru control 
(parallel -^ 

(transport header) 

(assign a-»cmory-data memory-data)) ; temporary memory control 
tUtspatch on kind, copy header to B side 
(par a I )el 

(assign b-temp a-nemory-data) 

(dicbatch-after-next (arrau-dispatch-f ieJd a-memory-data) 
((larray-dispatcn-shcrt-2d) 
IparafTel^"" ^•*^^*^-P'=»*'"^«^ 2) ) (set-type (array-rows-field b-temp) dtp-fix)) 

(?lturn)l?"* (stack-pointer 4)) (set-type (array-colucns-f ieid b-teinp) dtp-fix)) 
( (larr ay-d i spa tch- 1 ong-mu 1 1 i d » mens i ona I ) 
(errcr-tf (not-equal-f ixnum (array-dimensions-f ieid a-aeaory-data) (b-constant 2)) 
untKplfijBented-or-i I leasi-srray-type) tonox<5ni. ^, j 

assign b-temp (1- (array-iong-prof ix-lbnglh-f ietd a-aemory-data) ) ) 

;s Nou (airera (stack-pointer 3)) has the overall length and 

;; (aaem (stack-potnter 4)) has the address of the width — convert to U and H 

;; Thfs could certainly be more modular, ., but can't use the stack here 

(aemread (anen (stack-pointer 4))) *« o oLau^ ncro 

(assign a-posi t i ve-di vi sor memory-data) 

(assign a-negatt ve-di visor (- a-posi ti ve-di visor) ) 

(assign b- low-dividend (amem (slack-pointer 3))) 

(assign b-high-di vi dend (b-constant 6) ) 

(assign (amem (stacK-po inter 2)) a-posi tive-dt visor) 

(parallel (assign a-di vide-step-count (a-constant 15.)) 

(call dtvide-subrout ine)) ;15"32/2-l 

(parallel (assign (aaew (stack-pointer 4)) (set-type b-low-dividend dtp-fix) ) 
(return) ; } 
(otherwise (signal-error unimplemented-or-i I (egal-array-type) ) ) ) 
;5et casepointsr to word containing firct array eloaent, assuming fast case 
(parallel (assign (amem (stack-pointer 2)) y ^ 

(set-tupe (1+ vaa) dtp-locative)) 

.._^.^ (take-dispatchJn 

;:; 2-diaensionai array referencing 

;;; Don t use tne decoae routina on previous page to avoid extra apy and div 

;Catl with stack containing array and 2 subscripts 

;Heturn wrth stack popped once and "linear" subscriot in too-of-^tarfc m -iw-. ^.i i 

;Return «,th a-merpory-oata containing array header Sori a-ar?au hf « iL;i^S'°"'^\ . 

:Th,s a.cro.code checKS array type, dimensional i?S: aSbscr ipfty^ef^lnd^SundS'"' ""'" *^''"'* 
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Cdefaicro ZQ-arrau-maex c/ . ^. . 

'(paraiiel (check-arg-tupe array (am^s (stack-pointer -2)) dtp-array) 
(assian vwo lamem (stack-pointer -2))) 
(assign p-vr.a (atBcm (stack-pointer -2))) 
(ca.l I 2d-array- index))) 

(def'jcode 2d-apra',:- index 

iparaliei (start-Riemory read) 

(check-arg-tupj subscript top-of-«tacK-a dtp-fix)) 
(chcck-arg-type sucicrlpt next-on-stack dtp-fix) 
ipar»\it\ (transport header) 

(assign b-tenp memory-data) 

(assign a-renory-data memory-data)) 
(if (equai-f ixnun (array-di spatch-f ietd a-«emory-d3ta) tarray-diBpatch-ehort-2d) 
(goto 2d-arrau-index-short) 
IdroD-throughl) 
(error-lf (not-equ3! -f ixnum (array-df epatch-f ield a-itemory-data) 

Xarrau-dispatch*tong-Bul t idiaensional) 

untmpicmented-or-t I legaT-array-type) 
(error- If (not-equal-f ixnum (arrau-dinensions-f iold a-ReMory-data) (b-constant 2)) 

unimplemented-or-i I legal-array- type) 
(assign b-temp-2 (1- (array- long-prefix- length-field a*Kemory-data))) 
(assign top-cf-stack (a-constant 0)) ;accumulate index offset here 
(parallel (assign a-temp-2 (set- tune (+ vaa b-temp-2) dtp- locative)) ;la8t Hd in prefix 

(catt array-setup- long)) jSlouer than necessary, but... 

(assign a-oemory-data b-temp) {Restore array header 

(assign a-array-base (amem (stack-pointer 2))) (Base point-!r 
(assicn a-index-of f set top-of-stack) 
(parallel (assign vma a-temp-2) ;Get the number of rows 

(cai i puchnem) ) 
(parallel (pushval next-on-stack) stiees the second subscript 

(cal I 32-bi t-Biutttpiy)) 
(error-if (not (ail-ones (- top-of-stack Ccoiap I e«ented-s i gn-b i t next-on-stack) )) ) 

i ( leoal-«ubscr ipt) ;multip!y ovcrf ioued 

: — this bounds checking probably has bugs in it — - 
; — pho cares» the array format is going to change anyway - — 
(assign b-ter:;p-2 (amerr, (stack-pointer -3))> 
(parallel (assign top-of-stack (+ next-on-stack b-tenp-2)) sadd first subscript 

(error-if (minus-f ixnun obus) t 1 iega I -subscript) ; check for overflow in add 

(decrement-stack-pointer) ) 
(parallel (error-if igreater-or-equat-f ixnua-unsigned top-of-stack (aeem (stack-pointer 2))) 
i Ttegai-subscr ipt) 

(decrement-stack-pointer)) 
(paratle! (assign top-of-stack (+ top-of-stack «-index-of fset)) 

idecrerrrrt-s tack-pointer) 

(return))) 

(defucode 2d-array- index-short 
;; Short, fast case. Data follow header i««ediately 
(assign a-array-base (set-type (l-t- b-vma) dtp-locative)) 
;; Chick bounds 
(error-if (qreater-or-equa l-f txnuw-unstgned next-on-stack (array-rows-field b-temp)) 

i Ticgat-suDScr ipt) 
(error-if (qrcater-or-equa i -f ixnuM-unsigned top-of-stack-a (array-colu»ns-f ield b-temp)) 

: Tiegal-subscr ipt) 
;: Cotuttn-major order so multiply second subscript by first diiiension 
;: Doing 3x3 unsigned multiply with no overflow poestbie, so open-code for speed 
(assiqn b-temp-2 Idpb b-temp S IG. 8)) ; array-rows-field in left half 

tparaliel (ur i te-mpy-x top-of-stack-a unsigned) 

(ur i te-mpy-y-from-high b-temp-2 unsigned)) 
(parallel (assign top-ot-stack (set-type (+ next-on-stack apy-product) dtp-fix)) 

(decrimcnt-s tack-pointer) 

(return) )) 

(definst ar-2 (no-operand) 
i2a-array- index) 

;L;ispatch cr. the array type field 
(paral lei (assign oyte-r array- i ndex-sh i ft-prom) 

(dicpitch-af ter-next (array-type-field a-Bcmory-data) 
((art-lb) (ar-1-ucode 1 nil nil)) 
((3rt-2b) (ar-1-ucode 2 nil nil)) 
((art-Ab) (ar-1-ucode 4 nit nil)) 
((art-6b art-string) (ar-1-ucode 8 nil nil)) 
((art-lSb art-fat-string) (ar-1-ucode IB. nil nil)) 
((art-q srt-p-list) (ar-i-ucode Uord nil nil)) 
( (ari-bcolean) (ar-1-ucods 1 t nil)) 
_ . (otherwise (signa t -error un imp lemented-or-i 1 Icgal-array-type) )) ) 
tPoint vma at the adaresscd data word 

(parallel (assign vma (+ a-array-base (Idb top-of-stack 27. byte-r))) 
(take-dispatch))) 

ic-?^m3t a£-2 (n:;-cperand smashes-stack) 
(^ d-£rr a-j- indE.-^) 
;Oicpatcn on tnc array type field 

(parallel (assign byte-r array- i ndex-sh i ft-prom) 

Idispatch-af ter-next (array-type-field a-eeraory-data) 
((art-lb) (as-l-ucode 1 nil nil)) 
((art-2b) (as-l-ucode 2 nil nil)) 
{(art-Ab) (as-l-ucode 4 nil nil)) 
((art-Sb art-string) (as-l-ucode 8 nil nil)) 
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((ort-lisD crt-fat-stping) fas-I-ucode IS. nil nil)) 

((art-q aPT-Q-list) (aa-l-ucode Uord nil nii)) 

((art-booiecn) (as-I-ucods 1 t nil)) 

(otheruics (s i ana I -error un i mpi cmented-or-i I legal -array-type) )) ) 
;PoiTit VHA at the addressed data word 

(para; let (assicn vma f+ s-array-bace (Idtj top-of-stack 27, byto-r))) 
(take-di spatcn^ } ) 



(def inst ap-2 (no-operandJ 

(2d-arrau-index) 

{paraiieT (pop2push (set-type (+ a-array-base top-of-stack) dtp-locative)) 
(nex t- instruct ton) ) ) 
;;; Array register accsssing i nstruc t i ens -— — — 



: flavor is ur ite. pushvat, or newtop 
(defrr. icro arrau-reg t ster-ucode (flavor) 

;Get control word, disontcn, check event count, set byto-r 
;Notc that the xct-ncxt cycle ia fruried inside the IF 
Mpsral (el 

(assicn b'jte-r array-index-ehi f t-prom) 
( increment-macro- immediate) 

(dispatch-after-next (array-regi gter-dispatch-f ield address-operand) 
.•(loop for n from below 7 *^ 

collect '((,n) (, (if (eq flavor 'write) 

*arr ay-reg i ster-ucode-wr i te 
*srrau-reQ i ster-ucode-read) 
, nth n ;{I 2 4 8 IS. q q q D) 
. (- n 1(?) 
. ^ . . . , , flavor))) 
_ 10 thcru I se (SI gna I -error un i rrp t emented-case- i n-arr a-^-reg i ster ) ) ) 
Kf ^gq^^^'-PO'Sjer address-operand array-regi ster-eveht-countJ 

i f*?*/*^' ^3" t type-check the subacript yet (spec field busy) 

(assign vma (+ address-operand (Idb top-of-stack 27. buta-r))) 

(incremcnt-nacro-iiiBediate) 

(take-dispatch)) 
;Need to trap out and re-decode array, toasthtng has chanoed 
(goto array-register-recompute)))) *. • woo 

(defmicro array-regi ster-ucode-read (byte-sir© boolean-hack result) 
(array-ucode-read »byte-sire »booiean-hack 

top-of-stack addrecs-operand ,r«8u(t}) 

(defmicro array-regi ster-ucode-ur i te (byte-eize boolean-hack ianore) 
(array-ucode-ur(te ,byte-sirQ , boolean-hack 

top-of-stack address-operand ncxt-on-stack)) 

''(arrlyJelisrerlu^SSe'nou;")?"^'"""' "«''«-*«'^> '.Subscript on atack. popped 
''Ur?l,I-r|g|-s?erIuSoSe''pufhv;T)r''*''"' need-.tacK) ,Sub.cript on .tack, left there 

<defi.st fast-aset (addre„-operand neede-atack IwihesrstacR) "''''* "" *''^''' '""'P'^' 

(array-register-ucode write)) 

;£ettfng ud array registers 

;Le3ve array on the stack, and push control word, bass pointer. 

;up-er ccund, and lower bound H^'^'icr, 

(definst setuo-ld-arrau-seciuential nc-operand 

iSfilM^r Vt^'^:''^ ^'"l^y decoding stuff, get first three uords on stack 
(parallel check-arg-typa array top-of-stack-a dtp-array) 

(ass f en vma top-of-stack-a) 

(assign b-vma tno-of-stack-a) 

(call array-sstup-ld-zero)) 
; Advance the stark-pointer to leave it on the stack 
(assign stacK-pointcr (+ stack-pointer (b-constani: 3))) 
;Al30 push the lower bound 
(paraitel (pusfwal top-of-stack) 

(next- instruct ion) )) 

;S2me as atiove but don't push lower bound 

;Ltaves 105 incorrect 

(de-finst setup-ld-array (nc-operand smashes-stack) 

(no-'n'^T btanaard array decoding stuff, get first three uords on stack 
ipa. allel (checK-arg-type array top-of-ctack-a dtp-array) 
(assign v;.i3 tcp-of-stack-a) 
(assign b-vma top-of-stack-a) 
<call crroy-setup-ld-zero)) 
;N-w if the lower bound is non-rero, either factor it into the base 
;potnt2r cr set .t to work the slow way. For now always the slow wag 
lit (rcro-f ixn'jrr. top-of-stack) ^ 

(arcp-tnrc;;jf7h) 
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Cfisaign (arra-j-register-dtspatch-f icid (aRten (stacK-pointer 1))) 
(D-CCn»tcnt 7))) 
tparatiel (assign stsck-nointer (+ stack-pointer (b-constant 3))) 
lna«t-(r.5truct ion) ) ) 

Sct^^up an array reoistpr,- with upper and tower bounds, for a eubset 
ot on arrsLi riet,nccj by standard from and to arguments (either can 
t.1 mj. which ffiQjnt uts tne cxtrems end of the array). 
"*«v'Lf^'5^'^"^ the arra^ is always zero origin, in its error checking 
---ot tno tounas. I tn not sure whether that is 3 feature or a bug. 
:- — there seems to be seme general fuzzy thinking here. 

*n"Lct''i^* i^ot c-2 What happens if have to use "siow array register" here 
toefinst setuD-l:j-s-ra-j-from-to no-operond 

;L3i I the stangjro a rray decoding stuff, get first three words on stack 
land cat the index-cffeet in top-of-5tack 

(parallel jcheck-arg-type array (aasr. (stack-pointer -2)) dtp-array) 
(assign v«a lame« (stack-pointer -2))) 
(assign b-vma (anem (stack-pointer -2))) 
(call array-setuD-ld-zcro) ) 
lAppIu jndfeK offset to upper and iower bounds, plug them in to array rco 
(para I ie I » a 

(cneck-arg-type subscript (ame» (stack-pointer 8)) dtp-nil dtp-fix) 
(if (daia-typo? (saem (etaca-pointer B)) dtp-fix) 
IsfequenTial 
(paral lei 

(assign b-temp (+ (amen (stack-pointer 0)) top-of-etackM 
;Thi£ check rs because us wrff be using unsigned coaparfflon later 
(error- if (minus-f ixnun oou*) i I icgal-subecrtptf J 
I This check is for TO being specified as off the end of the array 
(error-if ( lesser-f ixnuw (amera (stack-pointer 2)) b-tcmp) 
i I legal-subscript) 

.fi*Tn'^"J*"'*'"]?^!^'"P°'"^^^ ?^^ (set-type b-temp dtp-fix))) 

:If TO not spec If ted, use array's upper bound 

(drop-through))) 
(parallel 

Iw^^ilf^^-type subscript (aaien (stack-pointer -15) dtp-nil dtp-fix) 
(if data-type.'' (aseM (stack-pointer -1)} dtp-fix) ^ 

(sequential 

ierror-if (■inus-fixnua (amem (etack-pointer -1))) 11 lagal-eubscript) 
(assign (amen (stack-pointer A)) " -wauripw 

(set-type (+ (amen (stack-pointer -1)) top-of-stack) 
is «n^n- dtp-fix))} 

:lf hRCn not specified, use array's lower bound 
Jaesign (anem (stack-pointer 4)) top-of-stack))) 
;A!so Ijave the index offset on the etack, for programs that want to 
;know what their index mto the array really Is (e.g. string-search) 
(aesmn stack-pomter (+ stack-pointer (b-constant 5))) "<»' ^"' 
(parailal (pushval top-of-stack) 
(next-instruction)))' 

};end comment 

F:>linach>ucode>arith'*escape.l Isp.l 

;;; -»- JlodeiLisp; Packane: flier o; Baee:8; Lowsrcasetyes -»- 
;j; (c) Copyright 13S2, Symbolics, Inc. 

;; Hicrocode for arithmetic axcept ion cases 

;; This is a DcFS fila for the rest of the arithmetic stuff 

;Get defnicro and all his hosts 

un 

(declare (cond ((not (status feature Imucode)) 
(toad 'udcts)))) 

(de f i ne-enumcr atcd-va f ue-constants Br i thme t i c-b i nary-cperat i on- 1 nd i ces) 
(def i ne-er.umerated-va i ue-constants Br i thme t i c-unaru-opsrat i on- ind ices) 
(def ine-enumerated-value-constants sthcader-number- types*) 

(reserve-scratchpad-memortj 2478 2474) 
(defareg ar i th-operat ion- index) 
(defareg ar I th-operat ion- float ing-pc) 

M *^*'"«^*^P-?l-«tack is the operation- index and the b side rs ncxt-on-stack 
(defucode ar i th-binary-extnum-cai l-out ■t-c^ 

(paral let (check-data-type top-of-stack-a 

,, dtp-extcrided-number dtp-fix dtp-float) 

(jump an th-bmary-cal i-out))) 

:; Build call out frame: 

:: SP(I): ^* |f'qpk!^^k|i f 'liwl'^n^' SP«3):.IND-2; SP(4): Te»p{.yentuaMw table) 

;: Shift the arguments up by 2 stack locations 

(pushval next-on-stack) 

(pushval next-on-stack) 

:; Push unused slot (table) 

(pushval Quote-ni I) 

;; Push type index for aro-2 

(parallel (pushval (amera Istack-pointe^ -2))) 
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fcarr Znumer rc-dfspatch-fndex) ) 
;: Push type index fcr arg-1 
iparatlei (pushval (amem {stac>t-point?r -2))) 

(call ^numeric-dispatch- index)) 
;; Cant do this earlier for PCLSi^ reasons 

(assign (a^em (stack-pointer -5)) (s^t-type arl th-operat ion-Index dtp-fix)) 
;; If arg-2 has bigger index than arg-1, interchange the arguaents Heave indices alone] 
(if (greatcr-f ixnum next-on-etcck top-cf-steiCK) 

(sequent iai (assign b-tenp (arem (stack-pc inter -3))) 

(339 ion (arnem (stacK-pointer -3)) (amem (stacK-pointer -4))) 
(assign (amea (stack-pointer -4)) b-tesip)) 
(drop-through) ) 
(puEhva I ar i thme t i c-b i nary-operat i cn-d i epatch) 
(take-post- trap ar i th-b I nary-escape preserve-stack) 

;;. Bui Id cai I out frame: 

;; SP(2): PCt SP(l): IND-1; SP(2): Oper at ion- index; SP(3): TABLE; 

;; 5P(4): AflG; SPC5): Ten-.p {Eventual function); SP(b): Temp (eventual pc) 

(defucode ar i th-unary-cal !-out 

;; Leave room for eventual function 

(pushva I quote-n i / ) 

;; Push a ccpy of the argument 

(pushval (anem (stack-pointer -1))) 

;; Push the taole number 

(pushval ari thme tic-unary-operation-dispatch) 

;; Push the operation index 

(pushvai (-et-tupe ari th-operat ion- index dtp-fix)) 

;; Push the argument type index 

(parallel (pushvai (amen (stack-pointer -2))) 
(call Xnumer ic-dispatch-inoex)) 

(take-pcst-trap ar i th-unary-escape preserve-stack) 

(defato»ic-byte-f ield header-subtype-of-wd Xtheader-subtype-f ield MBory-data) 

;; Takes argument en stack, pushes corresponding index on the stack 
;; Error checking is for when this is an instruction 
(definst Xnunc-" ic-di spatch- index no-cperand 

(parallel (check-data-tyc- top-of-stack-a dtp-fix dtp-float dtp-extended-nunber) 
(if (data-tupe? top-of-stack-a dtp-fix) 

(parallel (newtop (set-type (b-constant 0) dtp-fix)) 

(next-instruct ion) ) 
(drop-through) ) ) 
(paral tel 

(if (data-type? top-of-stack-a dtp-fioat) 

(parallel (newtop (set-tupe (b-constant 1) dtp-fix)) 

(next-instruct ton) ) 
(drop- through) ) 
(assign vma top-of-stack-a)) 
(start-r.er:ory read) 
(ncp) 
(parallel (trcnsport header) 

(rs2i::n tCD-of-ptack (+ header-subtype-of-nd (b-constant 2) )) ) 
(parsllel tneutcp (ret-tt.pe top-of-stack dtp-fix)) 
(next-instruct ton) ) ) 

;; Convprt next-on-stack to flonums 

(def uccrie convert- f irst-f ixnum- to-f lonum 
(parallel (call convert-f ixnum- to-f lonum) 

(acsign s-temp (popval))) 
(paral iel (return) 

(pushval a-te_sp)))^ ^^_____ 

F : >LMACH>UCODE>ARITH . Ll SP .61 

;;; -«- HodeiLiep; Packaaernicro; Ba-e:8; Louercaseiyes -«- 
;:; (c) Copyright ISS^, Symbolics, inc. 

;; HicrocDdo for arithmetic prinitives 

;Gct defmlcro and all his hosts 

(cieclara (cond ( (not (status feature Imucode)) 
(lead 'udcis)))) 

;; Binary operations 

(definstl add- tcmed signed- immediate-operand 

(check-b i nary-or i thme t i c-oper ands- f as t s i gned- i mmed i ate-oper and lar i th-op-add 

tr.»,i^r. /. ♦ ♦ add-stack fadd add-overf low) 

tneutop (set- type 

(adu-checking-overf low top-of-stack-a «acro-8i gned- iaoedi ate) 

dtp-f txJ i J 

(definstl add- 1 oca I (address-operand needs-stack) 

(check-b. nary-arithaietic-operands-fast address-operand Xar i th-op-add add-stack 
/«« ♦ ^ r * . r ^ ^^^^ add-overf low) 

(neutop (set-type (add-check ing-overf low address-operand top-of-«tack) 
dto-f tx) ) ) 
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(definstl add-GtacK (no-onerand nesds-stactt) 

tchccK-binary-ar i thnetic-cperands-faat no-operand Xar i th-op-add add-8tacK 

fadd add-overf low) 
(pop2pjsh (ftet-type (add-chccKing-overf lou next-on-stack top-of-ttack) 
dtp-fix)}) 

(de'finstl sub-immttd signed-imffediate-operand 

icneck-rjin3ry-ar i thset ic-operanda-fast 8igned-i«mediate-operand Xari th-op-eub tract 

aub-stack taub) 
(neutop (set-tL'D9 

(sut-checv. ing-overf low top-of-«tack-a ■acpo-sianed-iaBediate) 
dtp-fix))) 

(dc-finstl sufc-iccal (address-operand needs-stack) 

(check-binary-ar i thBot Ic-operands-f ast address-operand tari th-op-«ubtract 

sub- 8 tack fsub) 
(ne^jtcp (set-type (sub-check i ng-over f to*4 top-of-stack address-operand) 
dtp-fix))) 

(definstl sub-9t3ck (no-operand needs-stack) 

(ctrcrk-binaru-2r i thmet ic-onerands-fast no-operand tar i th-op-8ubtract sub-etack fsub) 
ipop2pu£n (set-type (sub-checkinQ-overf lou next-on-stack top-of-stack) 
dtp-fix))) 

;;; This is trapper* to via f ixnuM-f ixnua overflou in an add instruction 
(defuccde £dd-overflou 

(parsilei (ncpZpusn (set-type (+ next-on-etack top-of-stack) dtp-fix)) 
ttrap-no-save) ) 

(takc-post-trap addi t ive-f ixnu»-cverf low preserve-stack)) 

;;; Tht» is trapped to via f ixnu»-f ixnum overflou in an subtract instruction 
IdeT'jccde sub-overt low 

(paraiiei (pcp2push (set-type (- ncxt-on-stack top-of-stack) dtp-fix)) 
(tr5p-no-?ave) ) 

(tske-pcst-trap aadi t ive-f ixnum-overf lou preserve-stack)) 

(de^insti logand-stack (no-operand needs-stack) 

lcricck-Dinci;*y-ar i thr.et tc-operar,ds-fsst no-operand *arr th-op-logand logand-stack) 
ipcpZpush (set- type (iogand next-cn-stack top-of-stack) dtp-fix))) 

(definstl togiop-starK (no-operand needt-stack) 

(check-birvirij-ar i trtmeT ic-operands-faat no-operand Xari th-op-logior logior-stack) 
(pop^push (set- type (iogior next-on-stack top-of-stack) dtp-fix))) 

(derinstl loo^cr-btack (no-operand needs-stack) 

(cf!ec*-ctnc.ry-ari thmet tc-operands-tu5t no-operand 5iar t th-op-!ogxor logxor-etack) 

ipjp^pijsn iact-type (iogxor naxt-on-atack top-of-stack) dtp-fix))) 
;s Binary predic&te^ 
idefinst lessp (no-operand needa-stacki 

(p^rat lei 

tcheck-binaru-arithfnetic-operanJe-faot no-operand Xari th-op-lessp les&p flesso) 

tdEr.reaent-Btack-pointcr) '"^ 

(if ( iesser-f ixnum ne>»t-on-8tack tcp-of-stack) 

(no to tru'jl) 

(gotc falsel)))) 

(def inst greatRpp (no-operand needs-stack) 
(p3rai te! 

(check-binary-arithmetic-operands-fast no-operand tari th-op-greaterp areatero foreatero) 
(decreaent-itack-pointcr) ^ * *^ 

(if (creater-fixnuffl next-on-stack top-of-Gtack) 
(gnto truel) 
(goto faieel)))) 

(definst equa I -number (no-operand necdc-etack) 
(para I lei 

(chcck-binary-ar i thnet i c-operando-fast no-operand 

(d«r.«ent.,tack-po inter) «ari th-op-equal-nuBber eqoa I -number fequal) 

(if ieaual-ftrnun next-on-stack top-of-stack) 
footo tru&l) 
(goto fatsel)))) 

;;; Unary predicates 
(definst zerop (no-operand needs-stack) 
ip^Tz i t e t 

(check-unary-arithmetic-cperat ion-fast no-operand tar i th-op-zerop zcrop 
/.^ / .. fzercp) 

iif (zero-ftxnum top-of-stack) 
(goto truel) 
(goto faiscl)))) 

(definst plusp (no-operand needs-stack) 
(par 3 1 lei 

(checK-'jnary-ari thmetic-operation-faat no-operand tar i th-op-p!uop plusp 
/., , fplusp) 

(;f (p!u9-fixnura top-of-stack) 
(gotc truel) 
(goto falsel)))) 
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(deftnst uinatp frjo-operand needs-statk) 
iparai (el 

(ch«CK.-un3ry-3rithm-tic-operatfon-f3st no-oparand Xar i th-op-minusp arnuep 

K\A {!Pinu3-f ixnua tcp-of-»tack) 
(go:o tr-jel) 
(goto faleel)))) 

{def i nst f i xp no-ODer?nd 

(if iaat^-tupt^ ;cp-of-8tack-a dtp-fix) 
tcoto tru£i) 
(drop-through) ) 
(if (not (date- type? tcp-of-atack-a dtp-extendad-nuober) ) 
(goto falselJ 
(arop-thPOu:;h) ) 
(tieir.read tor?-of-staok-sl 
(parallel (transport he.ider) 

iif (equal-f ixnum headep-*uDtype-of-nd th«ader-tupe-bianum> 
(coto truel ) * 
(goto faisel)))) 



J ; Unary operations 

idefinstl unary-Binu* no-ocerand 

(check-unary-arithaetic-optrat ion- fast no-operand tar i th-op-winLfs unary-Binua 
- ^ ^. atnus-f ionum minus-overf (ou) 

IneiJtop (set- type (sub-check mg-overf leu (o-constant 2) top-of-etack-a) 
dtp-f ix) i ) 

(defuccde winus-overf low 

(parallel (newtop (set-type {- (b-constan^ 8) top-of-stack-a) dtD-fix)) 

(trap-no-save)/ 
r"^.^*S?~P°5^"'''"SP adOf t i ve-f ixnua-overf lew preserve-stack)) 

itadd-bicnu!fl-digi ts a b c) does a signed addition of a b and c 
returninc two valu-s. The first is a 31 bit &u- and ths second is 
the next hioher 3^ btts of the sum. This is P.ccor.pl ithed by doing an 
unsigned adottion, ana then cocpensst ing for tha sicn extension of negative 
arguBiE ~\X*j, •* 

(defirist iadri-b i anum-ci gi ts (no-operand needs-stack) 

(para tie! (checK-f ixnijr.i-23rgs next-on-stack top-of-5tack 

(olhei-wise (signs I -crrcr wrong- tupe-arnurent any (tfixnun)))) 
(assign D-tcsp (+ next-on-ctack tcp-of-stac^J i 
( i t Siu-carry 

(parallel (assign b-temp-2 (- (b-constant 1) 

(Idb toc-of-stack-a 1 31.))) 
( jurnp add-bignum-digi ts- Interna I ) 
(decrenien t-3 tack-po i nter ) ) 
(parallel (assign b-tc.T,p-2 (- (Idb top-of-stack-a 1 3U}) 
( junp add-b i nnum-d i g i ts- i nterna 1 ) 
(decreaent-atar.k-poi nter) ) } ) ) 

;; (tsub-bignum-digits a b c) does a signed addition of a b and subtracts c 
;; returning two values. The first is a 31 bit cub and the second is 
;: the next h.pher ^2 bits of t^le sum. This is accorptished bu doing an 
\\ arluffcnta "^^ ^^'^ ^^''" compensating for the sign extension of negative 
(def inst i£ufc-bignunj-digi ts (no-operand needs-etacK) 

Ipcrailel (checK-f ixnum-^args next-cn-etack tcp-of-stack 

(otherwise (signal -error wronn-type-arcufnent any (t f ixnum) ) ) ) 
(ass 1 on b-temp (- next-on-stack top-of-stack)) 
( i f aiu-carry 

(para/lef (assign b-temp-2 (fdb top-of-stack-a 1 31.)) 
K]uT.^ 3dd-fcronua-di gits- internal) 
(dscrer,ent-3teck-pointftr)) 
(paral/et (assign b-teir.fj-2 (+ (Idb top-of-stack-a 1 31,) 
. . (b-constant -1))) 
( jump add-b t gnum-di gits- i nterna i ) 
(decrement-stack-po I nter) } ) ) ) 

(defucode add-bionun-dio I ts- interna I 

(para! lei fassTqn b-ti-^-? (- b-tetrp-2 (idb top-of-stack-a 1 31.))) 

idecr^riEnt-e cscK-poi nter ) ) 
(para I lei (check- f i xnor.i-iarg-a top-of-stack-a 

(otherwise (signal-error wrong- tyoe-arguraent any (:fixnum)))) 
(ass I an b-ter- (+ b-teap tcp-of-6t2cr;-a) ) 
(if aiu-carru 

(assign b-tenD-2 (1+ b-tcn:p-2)) 
(ar cp-tr.rntjrh/ ) ) 
(parallel (assirn D-tc-w-2 (- b-te?rp-2 (Idb top-of-stack-a 1 31.))) 
vc2crer.cnt-6tciK-po inter) 
(jump pack-bienuTi-digi ts))) 

(defucode pack-b:oni:r-dt gi ts 

(cuEhval iset-T'"--e (Idc b-terp 31. 8) dtp-fix)) 

.f^Tr?«.^;^^':'S y°f^^^ ^"^^'^'f' ^^* . ''S»5n bit is bottom bit of top uord 
;: These coi.la be the sa:::e instruction, but thcro is a AflUA, DPB conflict 
nl'^??-?" ;^^ tset-tupe (dpb b-ter.p.2 31. 1 a-tenp) dtp-fii)) *=°"^"*=^ 
iparai iul (pus^-.vai a-tcrp) 

(next -instruct icn) )) 

(defatoraicro neaal i ve-r?su I t 

(nicrocondi ticn a(u-31 true nil)) 
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;;j (Xlshc-btgnur-digi ta a b shift) perfcrms a LSHC on the bignuni 
;;; ihc htr^ner diptt o* the resuit ct shifting (b,a) up is the va 
(definst liehc-bigr.'jf^-digi ts {no-oper£nd needs-stack) 



digits, 
lue returned* 



(para)iel ichecK.-f ixnur:i-2arcs next-on-stacK tcp-of-stack 

(otherwise (signal-error wronQ-type-arcument ang (rfixnuQ)))) 
(assign a-tefrjp top-of-stacK) 
(dccrement-stac<-po inter) ) 
(assicn byte-r (- a-ten-.p (b-constant 31,))) 
Cparaltcl (assign byte-s (1- a-teirp)) 
(i f negat 1 ve-resut t 

(parallei (check-f ixnum-larg-a next-on-stack 

(otheruisB (signal-error wrona-type-arguaent any (sfixnura)))) 
(assign b-ter.p-2 (b-constant 0))) 
(parai lei icheck-f ixnL-fr.-larg-a next-on-stack 

(othergjce (signal-error urong- type-argument any {:fixnu»)))) 
(assign b-te::ip-2 (Idb next-on-otack byte-a byte-r))))) 
(parallel (assign byte-s (- (c-constsnt 33.) a-temp)) 
( i f negat ive-rcsul t 

(parallel (pop2push (cet-typft b-temp-2 dtp-fix) ) 

(next- instruct ion) ) 
(drop-thrcugh))) 
(assign byt^-r a-terr.p) 

(paraiiel jpop2puch (set-type (dpb top-of-etack-a byte-s byte-r b-teBp-2) dtp-fix)) 
Ineyt-tnstruction) ) ) • " ^ 

::! !un''«!i.^!r^i°"''"'"^'2i^» *^ y' multiplies the fcignuE digits x and y and returns 
:;; two o^igi s uhicn are tno double precision product » w = 

tcefinct ^n-jlt,p|y-oi-nu'.:-digits (no-operand needs-stack) 
(ch-rk-f ixnuc-^srgs n«xt-on-stack top-of-ctack 

'-.at?^''^-"!:'*^ i2---^3';e"rcp wrong-ujpe-apgurr.ent any (tfixnum)))) 
.'-aiL-^^-i^^t-^:u.t)ply; . jq^ i 5.J^ • gh order uord 

(paraltel (assign b-tepr:p-2 top-of-stacK-a) t 

(dscreaent-stark-pointer)) 
(parallel (assign b-terp top-of-stack-a) ,ir.uh:4. 

idecrement-stack-pointer) ^'"°" °'^* 

{juap pack-btgnua-digita))) 

:;; (Xdivide-bionum-din: ts low high x) concatenates two 31 bignuni dloits 
-? .^-tV P?S'^'^* C2 bit nuaber. and divides it bu anothlr pos ? v2 
Vi:*'?^ ort dty:t. Rerurns the quotient and the remainaer PO»<tive 
tdeftnst Xdivide-btpnum-dtgits (no-operand needs-stack) 
(parallel (cherK-f (xnun-2srgs next-rn-stack top-of-star-k 

(assign a-ntgctfve-divicor (- a-poFi t ; vc-divisor ) ) 

5^!!?? ?-5'^'?*-«IsP''^"ount (a-constant lb.)) - See divide routine (22 «f^n*> 
(paraiiel (assic^n b-lou-dividend next-on-«tack^ u»v,ao rouime i^z steps) 
(chcck-f ixnum-isrg-a next-on-stack 

:; Lou bit of*h!;;r";'?.i'^?^^'b?rcf r^s^^-*""-*"""'""* •"« («*«-"■)'») 

t«iS»irin b-lou-r.i vidend {;int> tOD-of-st.-*c:k-« 1 ^1 k i^.. ^\^:^ -i\% 

(para lie I "*"'^'^'" '"*-^'-'P* b-loM-divid«nd dtp-fix) cdplnext)) 

;;j Arithmetic Shift 

x7 cycles to shift left 
;5 cycles to shift right 
(aefmst ash-stack (no-operand needs-btcck) 
(ps'-al le! 

(check-binary-arithaetic-operands-fsst no-cperand lar i th-op-ash ash-stack 

lis t^' ^. "' ' nil ash-fjoat) 

(if (ainu?-cr-rero-f txni'*i top-of-stark) 
;; Shift right by LDSing 
(tcquenliai 

(assign byte-r top-of-stacK) •Rieht rnta+» 

;: Get w-rd fu!! of sion bi\5 .«»5^t rotate 

(assicn D-ttr.p (- (idb'ncxt-on-stack 1 31-))) 
(parallel 

(assign bute-s U (a-cpnstcnt 31.) tcp-of-stack) ) jButesize.l 
(if (rsjnus-f ixnum obus) iwyucai^e ^ 

;; Shifted cway— result is aU elon bits 
(paraUet pop/push (cr^t-tuoe b-temp dtp-fix)) 

(next-instructioni) 
;; Nornsil result 
(paraljet 

(pop2push (set-type (Ido next-on-stack bute-e byte-r b-ters) 
, ^ . dp- fix)) 

^ (ncxt-instruction)))) ) 
;: Shift left by DFBing 
(sequpnt ia f 

(parlT?e !"'"•• top-of-stack) .^ discarded bits.1-1 

(assiC'i bytc-r (1+ top-of-ctack)) 
(i f Itrtnoo-f jxnum next-cn-ctack) 
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;; Arc'j-'^nt Ta negative 

;; Check that discarded bits and new sign oit era aM ones 
(If (afl-onea (IdD next-on-stacR fcyte-s Dyte-r (b-constant -1))) 
(sequent iai 
(asDirjn tpyte-r tcp-of-stacK) jLeft rotate 

(p^rai/el ^ ^ , ^ ^_ :N kept bits-1 

ts^stgn byte-s (- (a-cor:st2nt 31.) top-of-stacR) ^ 

iif (greater-or-equal-f ixnua-unsignsd (a-constant 31.) top-of-sta-k) 
Ipara Mel 

(pcp2puch (set-type (dpb next-on-etacK byte-s byte-p 0) 

dtp-fix)) 
(next- instruct ion) ) 
t^ ♦ . w^^*° ash-oyerfiow)))) , Shi ft count too large 

(G^to ac.'p-overfJcwn iResul t is bignua 

;; Arnurent 13 positive « v «- 

;: Check th2t discardC'J bite and neu eian bit are all zero 
lit izero-fixnua (I do next-on-stack bute-s bute-r}) 
{eequcntial 

(assign byte-r tcp-of-etack) ;Left rotate 

^Pf3'!^' , , tH kept bita-1 

(ass I en byte-8 (- (a-ccnetant 31.) tcp-of-stack) ) 
(if joreater-or-equal-f ixnuB-unsigned (a-constant 31,) tcp-of-stack) 

(popZpuiih (set-type (dpp next-cn-stack byte-a byte-r 6) • 

dtp-fixj) 
(next-instruction)) 

*«.♦« ».i-'*° ?T'''?^r7fl?^^^^^ 'Shift count too large 

(c^cfucc.e ash.ove-fioE°*' ^^^-°verf I o.) ;))))) ) ,Re3ult is bignur. 

(parallel (assign ar i th-ooerat ion-ind*x lar i th-op-ash) 
(jl:lid ar ( th-bjnaru-c3/ 1 -oat)) ) 



; Louarcas«:yes -«- 



e viia) . 



t;i -»- flodeiLisp; Pack£;o«:nicroi BaGt*:8; 
;;; (c) Lopv;ri^ht iS32, Sycaolics, Inc. 

J nicriicodo for A-iteaory rap en the Rev.l FEP board 

tGet dsfaicro And all his heats 

(dcci cre (cond (<noc (status feature lojcodaJ) 
(lead 'adds.'))) 

fUrite the Amc;::i map. ^riortzt cust have bft«ri tet up in VmA prevJously. 
;r.u5t ur* ElQt.?;f>t Eper:^ to Lbus is stur^le during writs puies to RAI1 
;Mi&o oats D;ist n-t co.tr froni cass-cro.jnd path (it won^t if ucu juat wrot 
(d3lsi -cro wr i te-'?..ei'ii-n'.3p (J3tn) 

'(paroUel (;.jr i ie-lbu'^-ncv 33 3 ♦dST-*) 
' (oic-oinstructicn cpeed 3))) 

(defuccde clear-anew-rcp 
(paraiief (as5ic- s-tprp (- a-teirp (t^-constant 1.8))) 

(if (t:Tinu?-f ixnun: ODus) (return) (drop-throuqh) )) 
(?-si?r. n-terp tIcTo a-teap 2 16.)) 
(3LS; pa v-3 a-te;~,j^ 
(carii let (u:r i te-arem-n.to D-tertc) 

(jusp L-ie3r-£n:eni-tc2;j)) ) 

(d-^f;:ccve s-tup-^rj^r-n-map ,Set up the direct-aapped part 

?'tiir;n Lj-:c-p iicizi a-terp 2 13. (b-cnnetent 1^))) hh h 

(o5--iOT v;;.T a- ter..p! 
(wr i ie-2r.:eci-fftap b-ts^p) 

(assirn a-teno (+ a-teirp (b-con»tant IS)}) 
(it ncj-::(t-test a-tecp 21.) 

(return) 

(gotc eetup-ocisa-c3p))) 

:Uritc a-tens intc the amcm-cap. A eufcrouttne only due to field conflicts 
x:ind £lfo tne need to Mriie the VHA. T'«cts 

?NjiE: U^-L: u-2n liritinrj tha aacifc-nap. the data Bust net cone from the 
jpass-r-^rurH nath, cecauea that doesn't give enough tine for the Lbus to 
:^b2 ntoV;L- -fr^ors ths write pLil3a Iru.-irur.p a elou cucie doesn't rake the 
•jp:;.:i-dr.:; -^a C33:: taster, sincs it is a negative delay frca the end of 
***'*■' ---'.^ !'.•£ is ?!l creeks for the temporary eeccry control. 
-.lie- ^zo^e yr t te-'-r:'-ir-n.2p 

(asbin vxa a-t-r=r) jClcars past-around path 

iparaiiet tur i te-a^-n-map a-tCEp) 
(return) ) f 

:Unr3r psge ^hct? or:::res2 (lew 8 bits zerof) is in b-temp, 8aa6?»ing a-terrp» via 
tC3 tuc-'J£ uniTcp-p; "r^-frcBi-ar.sTi 

(3£.ui'jn s-teTp iT'Jb b-teap 2 10.)) 

(apc>r-, yi;3 t-ter.ip.i ;Ctear3 paes-cround path 

iparsilei (wr i te-33ieiB-c3p a-tecp) 
(return) i) 

MICROCODE BITS 
Amem rnicrocode data. 

2: 0eO3?O338e?3 800883008088 008083880003 008883333330 
A: 033^33333300 088380088080 008000083338 033330330S30 



10: ec2C3203aeea 

1^: C3CC3C33eeC3 

20: eCC2CC330e30 

24: - ei'c.?oc.-»cec33 

33: eococ^ssecoa 

34: e32C33C33838 

48: Cw322Seee338 

44: 630333333333 

53: 633333330330 

54: 353333330333 

B0: 033330030000 

54: 638333330308 

Bmem microcode data. 



593 

808000000000 
000000080300 
033000000080 
000308088830 
000000003383 
030003000030 
833080030003 
6C3320S83333 
033030003000 
030000000080 
000008000000 





4 

10 

14 

20 

'•1 / 

30 
34 
40 
44 
50 
54 
GO 
E4 
70 
74 



C000030O3000 
033333333838 
033300833310 
003333333333 
600303318338 
037703803333 
603330303235 
0C3C3S403333 
6B333332BC33 



603333300442 
83333330301 1 
683330333203 
177777503333 
001777770800 



600000000000 
600000000000 
6000O004O21B 
003000000040 
003088000031 
017748888080 
603000000231 
003000009177 
028330003400 
0303301 0001 B 
608300000014 
000000000012 
6O00000577SB 
003333037777 
008080001077 
600000004100 
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600000000330 
600000000000 

000000000000 

000030003033 

000000000883 
000000030033 
003300000333 
033330333038 
800808383388 
030000003833 
600000000000 



860600000000 

638800000333 
600300038330 
000000003334 
008800001400 
020000000000 
031700000033 
000080000325 
000803377777 

000000040000 

600000000007 
177777777775 
660000000017 
600377777400 
001777774000 
600000050080 
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000003833333 
000333333338 
000003333333 
000003383333 
000000333333 
000333833333 
038333332333 
038333333333 
883333833333 
833333333338 
688883003388 



688000000300 
000000333300 
000000033302 
000000000037 
600077770000 
177777777777 
000040000300 
009400830030 
000000037777 
60000004003d 
000000000005 
600000000403 
660083833313 
000004000030 
600000005100 
600000000770 



Cmon microcode data. 



6 

4 
B 
10 
12 
14 
15 
20 

^^ 

24 
2B 
30 

34 

3S: 

40 
42 
44 
45 
50 
52 
54 
55 
BO 
52 
54 

BE: 

70 

72 

74 

75 

103 

102 

104 

IBZ 

lie 

112 
114 
115 
120 
122 
124 



6003S33220000O333103B000S377B31000 
084 854 3B2000O3B32003B0002003220034 
008033322800833331 035686S377531 080 
08'43177B32142O3720737524B777B024B2 
0343333225142085200000334037020000 
0333552510332002500353508420331633 
6353334233310033200017602077720377 
033:343221683383203350003000332400 
0e31lD?323B323332e5377OlB377B3ie83 
0332345221003333200360003000332400 
0331052520002323235377035377531000 
0333334521080683203350003300332400 
0031 1 El 22001 8303205350005377503044 
004351 722030300320035008851 1320380 
6833333223333035310358383377531000 
0333555520333333201 3E88851 02431 000 
6331155520032833285377015377531000 
0340755523142035283350504003221375 
00311BES2B302030265377015377S31000 
fc34233521C333332S073S000S777B31600 
0631 16S52e00203020537761B377631 663 
6337255533012080200000033000350000 
0331 1 5552888283328537701 5377631 000 
6331 77C532C3200020000050S377531 608 
6331047520332330235377605377531600 
0343333253338883203360035777702405 
0331353320032333205377035377531633 
0C31 3533:3142333283257505251242417 
0331C5122CB3283O2G537700B377B31000 
033141 5523332838S303S0565377531 033 
0331631E2C33233326537733S377S31033 
0343347523232333203417105377728377 
0333353223332333310358005377531000 
0441344632824384145135245055212000 
0033833228883333310350005377531000 
03425412:3333546232350025103502521 
0330333220333333310350005377531000 
0337353533832333200003503003331000 
003333322088333031 03S000S377E31 000 
0333717211012032500356583833530000 
03C3OG02203OOO8031035008E377B31000 
03331 1 1 B21 003339288600803000302024 
03333332233333333103S33OS377E310O0 



6004032B203333041404200050702O2231 
6341255528883383233358802003223334 
0340177232142837207375245777502452 
0001553220384003200350003505202433 
0441ie52203140O21C5025035377S12e:'3 
0833375220035583310350333377502433 
0083335221000000200330033003332433 
0032345521003303230350333000332433 
0081743520142332153320335835812333 
0002344521000963203350033033332433 
0002343521000003233338333333332483 
0803475521030083283330333030332439 
0323521220312000333377133377542425 
6802S352200145421033=2203377E3:525 
e3221355200120O333845704B377E3O330 
0040900272142035503377075777712333 
0000333273142331503383332083352339 
0342233232005803283330332377223375 
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?i?l' fi?if?^?ggg§f§§310360005377631000 0023354620015560200377106377531000 

?f^?* !S^§ZZS§i5§00002S07360006777630000 0000002B20142370600375200514431000 

ti?S- S§?illgil§§?g?§S5105§000S377631000 0000003220142370500375200514431000 

^ilS- 5g^§5502Z2020000203377175777502407 0002333620000003170377045377571000 

4700: 8040000250000000200400036377520000 0042231522002000213374706777602526 
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4702: 0842874228318000291362944354220377 080757S232002000200021040S01431000 

4704: 000121BE200000002003S0000591431000 0400473S201S4370S00377240514452000 

470S: 008425B23380e8802883S8803000383051 00042S2233000008200350003000303052 

4710:- 000008022000080031 03S000S377S31 000 00042S1233080008208358003009303053 

4712: 00042B02330000002903S00030003030S4 00042572330000002803S00039903030S5 

4714: 003800022000000031 03S000S377B31 090 000051 1232002000200023599400431000 

4716: 0001 135B201 4237060337738051 4431000 0000473620142370600377390514431988 

4729: 988£388228838888310359986377531999 9482235228154981280157245377652808 

4722: 0408114628164831289157246377552888 8488471228154881288157245377652000 

4724: 0000000220000000310350006377531000 0401317220154001200157246377652000 

4726: 0041 123520003000212360006377602525 0041124620000888212350005377602525 

4730: 0888000220080000310350006377531000 0041125220000000212360005377502525 

4732: 2301523220000003288468888501512000 0041555521000000290000903000322001 

4734: 0008030228000383310360085377531000 0340038261288800203350035777502405 

4735: O04027322300S004 140400006054120000 0003373620005540200360006377571000 

4740: 1141653220004000290360000505220000 0000000000000000000000000000000000 

4742: 9000030030088000000000000000000008 0000003308888880080000000000000000 

4744: 0003000228833338310360006377531000 0000000000000000000000000000000000 

4745 : 0030333883833838888888800000000000 0000000000000000000000000000000000 

4750: 033003022000388831 0358886377631000 0000000899999990999900000000000000 

4752: 0008099000883883888888888888000000 0000030000000000000000000000000000 

4754 : 000000022000000031 0360006377531 000 8000000000000000000000000000000000 

4756 : 0000388800330000080000000000000000 0000000000000000000000000000000000 

4750: 000003022000800031 0350005377631 000 0000000000000990000000000000000000 

4752: 0000000000000000000000000000000800 0000000008880999998888388886883888 

4754: 0000038228338888318368885377531000 0000000000000000000000000000000000 

4756 : 0000038800038833338888888888888888 0000000000000008080000000000000000 

4770: 0000000220000000310360005377531000 0008888888000000000000000000000000 

4772: 0000080000000000000000000000000000 0000000000000000000000000000008000 

4774 : 000000022000000031 0350006377631 000 0000000000000000000000000000000000 

4775: 0000000000000000000000000000000000 0000000000000000000000000000008000 

5000: 005241 052001 5550200377005377760377 0000000000000000000080000000000000 

5002 : 8000000000000000000000000000000000 0000000000000000000000000000800000 

5094: 4964152729916550700377005377750377 0000000251000000200000032000002200 

5005 : 8000000000000000000000000000000000 0003300000000000000000000000009090 

501 0: 124241 2620083440200360005377520000 0000000030000000000000000000000090 

5012: 8000000000000000000000000000000000 0000000000000000000000000000000099 

5014: 1044075720005540700377005377560000 0000000261000000200000032000002200 

501 5 : 0000000000000888888800000000000000 0000800000000000000000000000000000 

5020: 1044120320005500700377005377666000 0000000251000003200000032000002200 

5022: 0000038838880833888688000000000000 0000000000000000000000000000000999 

5024: 1044120720003470700377005377620000 0000000261000000200000^2000007201 

5025 : 6000000000000000000000000000000000 0000000000000000000000000000000000 

5030: 1054164720010573700377005377720377 0000000261000000200000032000002201 

5032: 0008000000000000000000000000000000 0000000000000000000000000000000090 

5034: 1064157720012573700377006377720377 0000000261000000200000032000002200 

5035: 6000000000000000000000000000000000 0000000000000000000000000000000099 

5040: 1064155720015541700377005377720377 6000000251000000200000032000002200 

5042: 6000000000000000000000000000000000 0000000000000000000000000000000000 

iS?^- lli^ik5H§?5§i^^^^3SO0O5377B2OOOO 0000000000000000000000000000000000 

5045: 0000000000000000000000800000000000 0000000000000000000000000000000000 

^M'' iIiiiili280004402O03e000S377B20O00 0000000000000000000000000000000000 

5052: 0000080000000008000800000000000000 0000000000000000000000000000000090 

Ifl^' il^i^llli§§g5fti5^5g5l^0^37752O000 O00O0O0O0OO000O00O0O0OO00000000000 

iSII' §f?§??S^SSSS^^?§§§§§§^^^^^^^^00000 0000000000000000090000000000000000 

Ifif* ll^^^iiiigg52i^gi5§35O0O537752OOOO 0000000000000000000866000000000000 

ii^?- f??l???f?i§?§??f§g§S22252§§5?2^^^^ O0000O000OO0OOOO00066666O000O0O000 

lii^ ' iiSiili^iSS2^^^5^22^^25^S377S2000O 0000000000000000000800600000000000 

5055: 0000330000000000000000000000000000 0000000000000000000000000000000000 

!§?§= ii^iili§ilig^i^fi§5^if5^37762OO00 0000000000000000000666888888888888 

5872: 8803883008803000000000000000000000 0000000000000000060666000000000000 

f^l^'' §225^2^^^55^3000310350005377531000 0000000000000000000866680000000000 

f^l^' g000500300O8830000O00000O0OOO0O00O 0000000000000000000000000000000099 

1} 2§= S52222E?22523503i 0350005377531000 0000000000000000000888800000000000 

51 02: 8000000000080003888668880000000000 0000000000000000086686660000000000 

i}^= l22l225s^5522225E23so006377S3iooo 0000000000000000008666688888888888 

i}?§= 8888888888838338838866688686888888 8688888688666880068886660000000000 

IHf = f 222222ii2222222i);52^950S37763i ooo 0000688888888000000888880000000000 

f\ \^- 0003008000000033880000000000000000 0000000000000000008066000000000000 

l\\^' 1222222^^52222555^^350005377531000 0000000000000000O0O08OO0O00O0O0000 

IWV ff2l5222222222255?522525?000®00000 0008888668868880008880000000000000 

1} if- £222222ii2222222E2i5522§F7S3i 000 0000000000000000000080668866888888 

IJi?- §2222255555552552055^0000000000000 0000000000000000000000686000003000 

l\lf' 2222222^^5555555il03S000S37763i0O0 0000000000000000000000000000000000 

1\IV f2522222222222255?0000000000000000 0000000000000000000000000000000900 

51 30: 000033022000030831 6368886377531 688 0888888800000000000000000000000000 
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51 32 : eeeeeeeaaeeeeeaeeaeeeeddeedeeedeee eeeeeaeeeeeeeeeeeeeeeeeeeeeeeeeeee 

5134: e0eQ00a22ee0e0093i03S0ees377B3ie0e 0000000000000000000000000000000000 

51 3B: 0000000000000000000000000000000000 0000000008000000000000000000000000 

5140:- 000000022000000031 03B000S377E31000 0000000000000000000000000000000000 

51 42 : 0008000000000000000000000000000000 0000000000000000000008000000000000 

5144: 0003080220000000310350005377531000 0000800000000000000000000000000000 

51 45 : 0000000000000000000000000800000000 0000000000000000000000000000000080 

5150: 0000000220000880310360005377531000 0000000000000000000000000000000800 

5152: 0000000000080000080000000000000000 0000000000000000000000000000000888 

51 54 : 088888822888088031 0350005377531 000 0000000000000000000000000000000088 

5155: 0000000008008000000000000000000000 0000000000000000000000000000000000 

51 50: 000000022000000031 0350005377531 000 0000000000000000000000000000000880 

5162: 0000000000008000000000000000000000 0000000000000000000000000000008888 

5164: 008000822888800031 0350005377531000 0000000000000000000000000000000000 

5166: 0008888888000000000000000000000000 0000000000000000000000000000000000 

51 70: 0000000220000000310360005377631 000 0000000000000000000000000000000000 

5172: 8000000000000000000000000000000000 8000000000000000000000000000000000 

51 74 : 000000022000000031 0360005377531 OOO 0000000000000000000000000000000000 

5176: 0000000000000000000000000000000800 8000000000000000000000000000000000 

5200: 1064155573004003700017032877720377 0000000000000000000000000000003000 

5202: 8000000000000000000000000000000000 0000000000000000000000000000000800 

5204: 1054160573006003700017032077720377 0000000000000000080000000000000000 

5206 : 8000000000000000000000000080000000 6000000008000000000000000000000000 

5210: 10641 12273006002700800532000060000 0000000000800080000800000000000000 

5212: 8000000000000000000000000000000000 8000000000000000000000000000000080 

5214: 1044075273020001700017032077720377 8000000000000000088000000000000388 

5216: 8000000000000000000000000000000000 8000000000088888000000000000000000 

5220: 1 0441 14573022001700017032077720377 0000800000000000000000000000000000 

5222: 8000000000000000000000000000000000 8000000000000000000000000000000000 

5224: 1044113273024001700017032077720377 8000000000000000000000000000000000 

5225: 8880000000000000000000000000000000 8000000000000000000000000000000000 

5230: 1041430720042002120377000501 460377 8001271520O420O757005700S37750240B 

5232 : 8000000000000000000000000000000000 0000000000000000000000000000088888 

5234: 1044071320000601700557006377620377 8065515620012000200140506377550377 

5235 : 8000000000000000000000000000000000 0000000000000000000000080000000000 

5248: 0542007620000088205580015377620377 0063355220155540200352546031060881 

5242: 8000000000000000000000000000000000 0000000000000000000000000000000000 

5244 : 864 1 35562000000020550001 5377620376 8004 1111 200000050003500053776024 30 

5246: 80200003201 50320605377806377602431 8000000000000000000000000000000888 

5258: 0641356520000000205588016377628376 8004111520000006000360005377502430 

5252: 0020000320150320605377006377602431 8000000000000000000000000000000000 

5254: 8541355620000000205500015377520375 0020008251010002500017032077702431 

5255 : 0000000000000000000000000000000000 0000080000000000000000000000000000 

5260: 8000000220000000310350005377531000 0000000000000000000000000000000808 

5262: 8000000000000000000000000000000000 0000000000000000000000000000000000 

5264 : 800000022000000031 0360006377631 000 OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO 

5255 : 8000000000000000000000000000000000 0000000000000000000000000000000000 

5270: 800000022000008031 0360005377631000 8000000000000000000000000000000080 

5272 : 8000000000000080000000000000000000 8000000000000000000000000000000000 

5274: 8000000220808000310350005377631000 0000000000000008800000000000888888 

5275 : 8888880000000000000000000000000000 OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO 

5300: 1045571320000470120377005377620377 8023265220010500010377006377603043 

5302 : 8008000000000000000000000000000000 8000000000000000000000000000000000 

5304 : 8002001 220002000000377006377631 000 8000000000000000000000000000000080 

5306 : 8000000000000000000000000000000000 OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO 

5310: 1044107720086501700377005377550377 8001441220002000000377006377631000 

531 2 : 8800000000000000000000000000000000 8800000000000000000000000000000000 

5314: 1044153720000501700557005377620377 0O5S546520012OOO2O014050S377550377 

531 6 : 0080888838800800000000000000000000 0000000000000000000000000000000000 

5320: 1044071720080B817005570O5377620377 0055550520012000200140506377550377 

5322 : 0008888888880888000000000000000000 0000000000000000000000008000000800 

5324 : 000888822888808031 0350006377631 000 0000000080000000000000000000000088 

5326 : 0000800888888088000000000000000000 0000088000000000000000000000000000 

5330: 000888322888000031 0350005377631 000 0000000000000000000000000000000000 

5332 : 0008880880000838800000000000000000 0000000000000000000000000000000000 

5334: 0008883228888888310350005377531000 0000008808888800000000000000000880 

5336 : 0000000003000000000000000000000000 0000000000000000000000000000000008 

5348: 064 1 355220000800205500005377520377 0000000000000000000000000000000003 

5342: 0000000000000838000000000000000000 0000000000000000000000000000000300 

5344 : 054 1 355520000838285500005377620377 0000000000000000000000000000000000 

5346 : 0000888888880080000000000000000000 OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO 

5350: 0542007520000000205500015377520377 00S424S2200100002053770053776200O2 

5352 : 0000000000000000000000000008000000 8000000000000000000000000000000000 

5354: 0542007520000080205508815377520377 8054247220010000205377006377720002 

5356: 6000000000000000000000000000000000 0000000000000000000000000000000000 

5360: 8642010520000000205500015377620377 8044142520000005000350005377620001 
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53S2: easee3e320i 50328505377006377620002 0000000000008000000000000800000009 

5354: 0542010520000800205500015377520377 8044143520000885008358885377528001 

5355 : 00580003201 50320605377885377528882 8888888880000000000000000880000000 

5370:. 0542010520000000285500015377620377 8053355220155540200362546831060001 

5372: 0000000000000800000000000000000000 0888888888888888000000000000000000 

5374: 0E42005G2000008020550001S377520377 0053355220155540200352545031058801 

5376 : 0000000000 000000800 000000000000000 0880000000000000000000000008880080 

5488: 6001476611816802448360503000530888 88800000000000000000008800818888000 

5482: 8080000080000000000000000000000000 0000000000000000000000008008888808 

5484: 6001475511215002440358583888538888 8888888888888880080888000000000000 

5406: 6000000000000000068808088800868080 0000000000000000000008868888888808 

5416: 6801476611416002440360583886536000 6800000080000000080688866866880000 

5412: 6000000000000800066600808008808686 6888888888888080880006886888888888 

541 4 : 6001 47651 1 616802448358503080530000 0000000000666660606080000008688888 

5416: 6808668888888888886666866866888868 6888888866888888600888288866688000 

5426: 6001477211015002446361643000538866 8888800O08808000BO000888888888880O 

5422: 6688886888888888886666668888668886 6888888808886666688666888888888800 

5424: 6881477211216882446361643668538600 0000688866666668666866668866880000 

5426: 6668666866686686666666868000000006 6000066686686688686866866866800000 

§^29- 000147721 1416682448351643868538886 6686668686686666666680000000000800 

5432: 6688666888668088886868868888668686 6668888688866666806668668688868808 

^1^* fggl^2ZiUS1588244836164388853e688 6668866666686668666686888888888838 

f^?^' ggg900§00000000OO000000OO0O000000O 6668686688688666866868666668888888 

i^^S- f22i^Z2§U§k§252446368S43888538886 6668688886668668006688886886880838 

5442: 6688866888888888668866888888868866 6888888888666668666888886888880000 

5444: 6881477511216882446366543666536686 6666888666666886866866688886688888 

5446: 6688668688688886866668886888888888 6688886686666066666666886688688836 

f^f%'' S§§l^22IU^k§§fiii5358543868536888 6688836688686866688666886688888800 

5452: 6008080088868888086686868886686886 6868008866888888688888688688888888 

f}f^' !52)i^mU§ki2^**^S6543688538888 6688886666886868868600000000008888 

5456: 6888888888886688800666688800000000 6000008666686666668866688688888808 

5466: 6881 56861 1 61 6882446366603088536886 6888808888888888666686686666660000 

5462: 6000000008888800000006808886866666 8886888888866688666886686668600000 

5454: 6001500511215002440366663888536668 6880000000000000686668888688838800 

5466: 6888838803000000006866868866688668 6648888258888888201356835371128081 

5478: f|01|f0ill$1588244K685838885366e6 888222122268266628^54288516831888 

5472: 8803252528148458268368885885842526 8821345228618688266377648512242884 

5474: 6831588511515882446368683688536686 6883245226884588266837646377571683 

WA' 1328838273858882286817172666642467 668222122268288^68354288515831888 

5588: 8881581211816882448366763868536886 6335546632864866268356688487582837 

|582: 8802312528888838286358885377631688 8801257226888866266358806377631688 

iil^= Sf?fff^iU^}5lg^^l§Z^00^36686 6888561222662888286377666568131888 

ii?l= 2^}iZ?i???}?5§§285377345377542464 6848143226884666260356682284821628 

5518: 6601561211415002446356763886538666 6822253228816888205377346377542454 

EU'' 2§^?^^fl????^gg?288368882284821828 682112262661666^^37734^ 

ii}^- fll}i?liUI}§f§i^^l^§Z^2§5§53e886 6843147226884668268368682264821826 

ili5- f 5ii§i?Si§§l 8888285377346377542454 6647665528664686286366882284021020 

5520: 6063561222832888286377686588131888 8624545226816688265377345377642454 

ili?= f5i}iZ5i28888863836356885377621373 8646343228668666636366885377521373 

5524: 6681758522802000200377000500131000 0063115232656575176026885377542487 

iiil- gg^^i^22?^^5Zil 78626886377642487 6020000250012666260157335377563885 

iii§- SS§^§^§i?5gi§§SiS3277608S8013ie6e 6888888273682666266681372688831886 

iii?- |g^5?§§S5lg£5050i28000032677782261 6883816526660478266368886377542414 

iii^- fifiLEii?lfi§gi288377e68588131688 6688866251688686266666832868882268 

ii?|- ???ff§?^§lgg?§25i03®3®332888882286 684757522614266S266366584882821375 

11^?* U^§??Ji??g§???5ig®3776885881 26868 6866343621866686266668663888362823 

Ilil* ????^i}lifiiili§i§§i??l§§?ZI?Zlg09«®^15252688554626637716537767ie88 

ilt^= U^?^i?ii52i039?3^77668566126866 8883153226886546268377186377671888 

5545: 6883153528835548238377165377671686 6883154626886546266377186377671663 

ill?= U^?fii?iig^??0^0®377668568126666 680315522000654^68377185377571608 

ill?* ???l}liii?gfi5^^g93Z71«S377571888 6883155528886546266377186377571888 

l^^^'- U^i}l^iii?SI??^552ZZ800586126686 6883157226886546266377165377671888 

Pii= Si2illZi?g5§S§^g^?93771 85377671 668 8683158626686546268377166377571888 

M^^'- i§if^2^ig5^25§5E^S688S377631666 6883151226886546266377165377571688 

ill?' gSSS^S^S^^^SS^^^^^^^^^^^^^^^^^^BB 6668668888686866666666868868666600 

Mi' S22^^2ii?2552®3^1 6366886377631888 6668888383886666686686666668800000 

i§§^' ^0^0000000000333836886888886688668 6888888888868666866666666866868688 

!§?§= 255255252883033831 8366885377631 886 6883888888886680668606688866668888 

Wl^' 0555000000000000000000000000000000 0000000000000000066666866866886888 

W,i'' 000000022800300031 0360005377531 668 6883338888888666666668666868688888 

5575: 68213185 32858 6 8228637 7148561442467 6668888251666608200666632677782288 

Won'- ]lfii§Si^ifSi§il§]^^55tl52^377526377 6652367526152686266946565868356888 

^5? ' 0008000000003003008600888888088888 6880000000000000068668888688888838 

Icflc' lfiifSl2ii5lii25ll^552Z55§2Z''S2e377 e0S2307528158688266641345688368e38 

5686 : 6888388886888688866680000000000006 0000000000000000000000888888888888 
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5518: 1842841 729088880120377006377529377 9882902528029888200358015377531 000 

S612: 0042257220000000290440905377720008 8888988888888880000900000000000000 

5514: 1042041722002000120417000507120377 00210C5S20012000200350500S07242434 

551 6 : 8888000000089090000000000999990000 0000800000009999909990000000000000 

5520:' 1042041722002080120377000501520377 0000005520012000000350745377592495 

5522: 8900000300000099999900000000000000 0998800009000000000000000000000000 

5624: 6000000220000080310350005377531000 0000000080000000000000000000000800 

582S: 8800000000000000000988000000000000 0043401228888470200350005377668000 

5630: 800000022000000031 0360005377531000 0000000000000000000000000000000000 

5532: 0000000273002000200001072000031000 0040211520000000200360005377631000 

5534: 5042755220000440200360005377620000 0040212520000000200360005377631 000 

5536: 8041345520000000208358885377531888 8851521232010000200377042077620377 

5548: 804 1 375220000000200420015377621 01 3 0044 1 235201 0003020052050051405 1 023 

5542: 8040800320000000200620006377621011 8000900251000000200000032077702200 

5644: 8041375220000000200420016377621013 0044074120100030200520500514061023 

5646: 8040000320000000200620005377621011 0000000000000000000000000000000000 

5658: 8041375220000030200420015377621013 0044074520100030200520500514051023 

5652: 804899932999999920062000537762101 1 8000000000000000000000000000000000 

5654: 8eS8o52S20O1200000036eS4637766O376 8853035533058576170017042088031888 

5656: 8883447228815540288377345377643818 0888888888888888888888868888888888 

5668: 888888822888888631 8366685377631 886 8668888888888888888886868888888888 

5652 : 8600000000000888000000000000069990 6060088000000000000000000000000000 

5654: 8000000220000000310350005377631000 0003451220015540200377346377643010 

5686 : 800345322001 554020037734537764301 6888886888686688886886860866888886 

5676: 8800088258822881 738351 67852268251 3 8888888888888886888888889888888888 

5672: 8888880000000000000000000000000000 0000000000000000000000000000000000 

5574: 8000000260022001730350570522502513 0004055222002000200000505377531000 

5676 : 800222 1 22200200020035420051 5031 000 00207552200120000003505053775424 1 7 

5700: 8044155120140000200350005014561376 6648886328162858288626888562851375 

5762: 8845741228605888266368882283021016 8008880000000000000000000000000000 

5704: 8040047520884009299929005377620377 8600000000000000000000000000000000 

5706: 8645743228885000200350002203021015 0000000000000000000000000000000000 

571 0: 80037 1 45201 4 04502003600060054421 06 004574462000500020035000220302 1 01 5 

5712: 0045745220005000200350002203021016 0003177220142474200157306350231000 

5714: 0003716520140450200350006005442106 0003353220006600200350000507402435 

5716: 0023000520150540200377006360003005 0001303232002060200360500405431000 

5720: 6025571 32001 7530200353505377502002 1203745220000440200350005377602017 

5722: 0003240520010640351362044350602405 0042637620142543200361346377660377 

5724: 0024215220016680200377000501430000 0000301220005000200020005377602000 

5726: 088S753220902000O4O377105377631O00 0803205520140460200350005005242526 

5730: 8000800220000088310350005377531000 0000000220000000310360005377631 000 

5732: 0000C002730020002OOO00532OO0O31000 0042325520000000200350002000020001 

5734 : 000000022000000031 0350805377631 000 0009000000000000000000000000000000 

5735 : 000000027300200020001 71 32077731 008 0000000000000000000000000000000000 

5748: 5344034220000000201 360006370421375 OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO 

5742: 8056751220012000200360500587060000 6688886888688866880888888888888886 

5744: 1147575228668800200020000501520000 8000000000000000000999990000000000 

5746: 8021053228012088266257466377642414 8686666688888666866888888868888886 

5756: 5341158528888868265358886377526688 8868886888888668886888888600000000 

5752: 8040000250142005200360534002021376 OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO 

5754 : 8021 55352001 5000040377005377630000 0000000261 000000200000032000002201 

5755 : 8040000251 000000200000032077720377 6886866666666688886868868868686886 
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5742: 0000207320001 400200350005377503005 0000000260000000200350035377631000 

6744: 0000888228886888310350005377531000 0040215220000000202350005377631000 
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674B: 002855322081 00982e813724B377E42434 00200002E015000420015733B3B0203007 

6750: 000000022000000031 03B000S377B31 000 0042317B20000000200000003000321000 

B752: 000DS71 320001 4002003S000B377B03005 00B0312B20014000200037006377720377 

B754:- 00000002200000003103B008S377S31000 00S0521B2001400020003700S377720377 

675S: 00080002S00000002003S003S377731000 0000080800000000000000000000000000 

B7B0: e00000e22000000031035000S377S31000 0000854B370508042003S0003008332400 

67B2: 0000000000000000000000000000000000 00000552370500042003S0003000332400 

67B4: 000000022000000031 03S000o377B31 000 0000055B370500042003B0003000332400 

B7SB: 000085SB37050e342003o0003000332400 0000057237050004200360003080332400 

6770: 000000022000000031 03B000d377S31 000 8000000000000000000000000000000000 

B772: 104204172200208011004050S377B20377 0022757220012B000103B170B37754240B 

6774 : 000000022000000031 03B000B377E31 000 0000000000000000000000000000000000 

677B: e002o42B20000000200400013000312800 0040753B200220002003B3542277421375 

7800: 080000022000000031 0360005377631 000 0000000000000000000000000000000000 

7002: 8000571320001070200377305377631000 0020000260012000280137276377603005 

7004 : 000000022088880831 03S0006377631000 0000000000000000800000000000000000 

7005: 0053475220155578200350545050051376 0000000000000000000000000000000000 

7010: 0000000220000000310350006377531000 0000000000000000800000000000000000 

7012: 0005571220000000310350006377531000 0080080000000000000000000000000000 

7014: 000000022000000031 035000S377S31 000 0000000000000000000000000000000800 

701 5 : 900420422001 0000205020505377632200 0000000000000000008000000000000000 

7020: 000000022000000031 0360005377631 000 0000000000000068800000080000000000 

7022: 0001 166620004000205375755377671000 0204462220000000200420006377512000 

7024 : 000000022000000031 0360005377631000 0000000000000000000000000000000030 

7026: 8002642620016530200353516377602002 0050331220000000721420006350232100 

7030: 0000000220000000310350005377531000 0000000000000000000000000000000800 

7032: 0044132520142000200240005026651011 0025733320007540200377505377671080 

7034 : 000000022000000031 0360006377631000 0000000000000000000000000000008003 

7036: 0044113620142006200360504003121376 0000000000000000000000000000000080 

7040 : 000000022000000031 0360005377631 000 0000000000000000000000000000000000 

7042: 8801354620142004200020015003443007 0000503233002000200000543000331000 

7044 : 800000022000000031 0350005377631 000 0000000000000000000000000000000008 

7046: 8005571320001400200360006377503005 0000000000000000000000000000000000 

7050: 8000000220000000310360006377631000 0000000000000000000000000000000000 

7052: 8001375620000000205360016377602000 0001551532010004140104105071002000 

7054 : 800000022000000031 0350006377631 000 0000000000000000000000000000000000 

7055: 8004053220000000205440015377602104 0043427220140460200350005005551375 

7060: 800000022000000031 0350005377631 000 0000000000000000000000000000000000 

7062: 8002122520142006200037005260603011 0000000000000000000000000000000000 

7064: 8000000220000000310350006377631000 0000000000000000000000000000000830 

7055 : 8002 1 232201 4200520003700626050301 1 0000000000000000000000000000000000 

7070: 8000000220000000310360005377631000 0000000000000000000000000000000000 

7072: 80821 1 05201 02250200377000507031 000 0000000000000000000000000000000000 

7074 : 800000022000000031 0350005377631 000 0000000000000000000000000000000008 

7075: 0003013520000470200360005377642524 0000000000000000000000000000080088 

7188: 0000000220000000310360005377531000 0000000000000000000000000000000000 

7102: 0004137520140000200360005027642022 0000000320000000200360005377631080 

71 04 : 800000022000000031 0350005377531 000 0000000000000000000000000000000000 

7106: 8801354520142004200020015004043007 0000503233002000200000503000331000 

71 1 0: 000000022000000031 0350005377631 000 0000000000000000000000000000008088 

7112: 0841504520000000205360005377520001 0000000000000000000000000000000088 

7114: 880808822800000031 0360005377631 000 0000000000000000000000000000000000 

7115: 0050222620150004200201745250560377 0000000000000000000000000000000000 

7120: 8000000220000000310360006377631000 0000000000000000000000000000000000 

7122: 0050223220150004200201745250650377 0000000000000000000000000000000000 

7124: 0000300220000000310360005377631000 0000000000000000000000000000000000 

7126: 0040373220152880200121505206460377 00000000000000000P0000000000000000 

7130: 0008388228888888310360005377631000 0000000000000000000000000000008000 

7132: 0040000252002000213375635777502010 0000000000000000000000000000003000 

71 34 : 800000022000000031 0350005377631 000 0003000000000000000000000000000288 

7135: 0003534520140450200350005005442022 0000030000000000000000000000000000 

7140: 0008800220000000310360005377631000 0000000000000080000000000000000000 

7142: 0083535628148458288368885885442822 8880000080000000000000000000000000 

7144: 800030022000000031 0360005377631 000 0000888888888888888888888888886000 

7146: 8003540620140460200350005005442022 0000000000000000000000000000000000 

7150: 8000000220000000310350005377631000 0000000000000000000000000000030000 

7152: 0004175120100038208358885377542813 0000000320142006200360504000002513 

71 54 : 000000022003888831 8368886377631 888 8000000000000000000000000000000000 

7155: 0000888258888888288368836377631888 0000000000000000000000000000000000 

7150: 8000000220000000310360006377531000 0000000000000000000000008888888888 

7162: 8885167228888800200360005377631000 0000000000000000000000000000000800 

71 54 : 000000022000000031 0360006377631000 0000000000000000000000000000003000 

7165: 0000000008888888888888888888888800 0000000000000000000000000000088000 

71 70: 80000C022000000031 0360005377631 000 0000000000000000000000000000008300 

7172: 004213322010205020002000S3776S1376 0000000000000000000000000000000000 

7174: 0000000220000000310360005377631000 0000000000000000000000000000088600 

7175: 0042177220004000232360014100202015 0043226520004640232360024100602015 
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7298: 0008eeS220B0008a3ie2G8e9S377B3ie0a 0008080000000088000000300000000000 

7282: 0000000000300882800000833080380008 0000008080030000000000000000080080 

7204 : 008800022000000031 03E000S377B31 000 0000000000000000000000000000000000 

7205 :- 0000800000000000000000000000000000 0000000000000000000000000000000000 

721 0: 000300822000000031 03S00OS377E31 000 0080000000080000008000008000030030 

72 1 2 : 0000003000000080000000030000000800 0000083000000000038833838800008883 

7214: 080000022000000031 03o0005377E31 000 0000383883883888833888800000000000 

72 1 B : 0000000000000000000000088388800000 0000000000000000000000000000000000 

7220: 000000022000060031 03B00OE377B31000 0000000000000000000000000000000030 

7222 : 0000000000000003000000300000000008 0000000000000000000000000000000000 

7224 : 000000022000000031 03E000S377631 000 0000000000000000000000000000000000 

722S: 80421772200040002323S0014100202015 8043227S20004B402323B0024100S02015 

7230: 000000022000000031 03S000E377B31 000 0000000000000000000000000000008000 

7232: 00001 05B200100002003B2050400002000 0001353B2000000020042000S377B02000 

7234 : 000000022000000031 03E000S377B31 000 0000000000000000000000000000000000 

723B: 000343522001 E5402003E1246377602413 0008800000000000000000000000000330 

7240: 000000022080000031 03B000E377S31 000 0000000000000000000000000000000330 

7242: 0001354S2014200420002001B003443007 0000B03233002000200000503000331000 

7244 : 008880022000000031 03S000B377B31 000 0000000000000000000000000000000000 

724S : 0000030000000800000000083000000000 0000000000000000000000000000000000 

7250: 000300022000000031 03B0e0E377B31 000 0000200000000000000000000000000000 

7252 : 0000000000000000000000080000000000 0000000000000000000000000000000000 

7254: 003030022000000031 03S000S377B31 000 0001354B20142004200320016003443007 

7255: 0800503233002000200001043000331000 0000000000000000008000000000000000 

72B0: 000000322000000031 03B000S377E31 000 0000000000000000000000000000000000 

7262 : 0000000000000000000000000000000000 0000000000000000000000000000000000 

72B4: 000000822000000031 036000B377B31 000 0001354B2014200420002001E003443007 

72SB: 00C3S0323300200020000054300033i000 000000000000000000C000000000000080 

7270: 000000022000000031 03B000S377631 000 0000000000000000000000000000000000 

7272 : 0030000000000000080000000000000000 0000000000000000000000000000000000 

7274: 000800022e0030003103B000E377B31000 0000000000000000000000000000000000 

727B: 0S4200SS2000000020550001B377B21001 004140722C0000002003S0000512420002 

7300: 000000022000000031 03B000E377B31 000 000405322000000020544001 E377B021 04 

7302 : 004341 722000SB00200000002000020000 0000000000000000000000000000000000 

7304 : 000000022000000031 03E000E377B31 000 0000000000000000000000000000000000 

7305 : 0000003000000000003000000000000000 0000000000000000000000000000000000 

731 0: 000000022000000031 035000E377531 000 0000000000000000000000000000000000 

7312: 004 1 407E200000O02023B000B377B31 000 0000000000000000000000000000000000 

7314: 000000022000000031 03E000S377B31 000 0000000000000000000000000000000000 

731 B: 02088882E1 880338288880032000012000 00000003200040002053B000S377B32200 

7320: 000000022000000031 03S000B377B31 000 0000000000000000000000000000000000 

7322: 00411BE620000O002053B001B377B20000 1722410B2015B5402003B050E032052000 

7324 : 000000022000000031 03E000E377B31000 0000000000000000000000000000000000 

732S: 00444E322000003020042001B377B20001 0040132622002000000377044377B2001B 

7330: 000000022000000031 03S000S377B31 000 0000000000000000000000000000000000 

7332 : 08007 1 BB320008002883E000651 1 003034 0000000000000000000000000000000000 

7334 : 000300022000800031 03E000E377E31 000 0000000000000000000000000000000000 

733S: 0001 003S2030000020042000E377B31 000 8000000000000000000000000000000000 

7340: 000000022000000031 03E000S377B31 000 0000000000000000000000000000000000 

7342: 0042177220004000233360014100202015 004331BB20004B40233350024100602015 

7344 : 000000022000000031 0360005377631 800 8080000000000000000000000000000000 

734B: 002ES7132001317020007700S377B02410 000063462005000120007714B377B72400 

7 w50: 000000022000000031 036000E377B31 000 8000000000000000000000000000000000 

7352: 002BB7132801317020007700E377B02410 0000E35220050001200077146377672400 

7354: 000000022000000031 036000B377631 000 0026671320013I7020007700B377602410 

7355: 0003E35S2005000120007714E377672400 0000000000000000000000000000000000 

7350: 000000022000000031 0360005377531 000 8000000000000000000003000000000000 

7362 : 8000008000000000000000000000000000 0000000000000000000000000000000000 

73E4 : 000000022000000031 03B000E377631 000 0000000000000000000000000000000000 

7356: 0026E7132001317020007700E377602410 0000E3B620050001203077146377672400 

7370: 000000022000000031 036000S377B31 000 0000000000000000000000000000000000 

7372: 00031 85233000000200000003000302405 0000000000000000000000000000000000 

7374 : 000000022000000031 036000E377B31 000 0000000000000000000000000000000000 

737E : 8000705E201 42000200037506257231000 8800000000000000000000000800000000 

^^5§- 5§55^22ii2?^2®®§31 83B880B377B31 888 8888000000000000000000000000000000 

VS^J^^ ^22^?^^^2??§^^^1®3B0006377B31000 0000000000000000000000000000000000 

7405 : 800070722014200020083750S2B7231 000 8888000000000000000000000000880000 

Vl\t' e0338032200000003103S000S377S31000 8000000000000003e3S 

??}?• f2ii?il^i§§i2i^5?2^25000S377S42523 0000003000000000000030000000000000 

Vl\^r} fg2?§f??iS?gg3003103B000S37763i000 00000000e0000000000000800K00000 

^Hl= f §^^§^ili2lgg522??g36000S377B4202B 88000003201 4200o20O3S050400020251 3 

l^lr ilfol5§ii§l^5^i^?52ZZi§§?§3402430 000000032000000O2003S0002000402430 

l^^o' £^?iiiiii£^§?^5£2i25§5g^377631000 8000000083838888308388800000000000 

7426: 8080000000000000000000088000000000 000761323300000020000000300030240B 
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7438: eoeaee022e000o?d3i esseeessyyEsi eee 8000800880088008000880000080088880 

7432: 88241 ie52ei5S5702O037758S0322O3884 e880e832S881208828O3D873858348241B 

7434 : 888888822888888031 03S888B377G31 888 6888888888888888888808800300030808 

743S:- 0024110128155570200377508032203884 68e88882S8880ea02003B003o377S31C80 

7440: 800883322088888831 03S000B377S31 000 8000000000008888888888800000033880 

7442: 0030330000300000000008008880800000 0004031220000300203350000511402015 

7444 : 003038822833300031 0350005377531 000 8803333883883808888888808888883033 

7445: 0883B172288383382803S8815377B31888 888345722880S50020035088S377B8241B 

7450: 800333322883330031 03EO005377531 OOO 0000000000003008000000000000030333 

7452: 0334454228833388288358815377531800 8824375228158000200375444052032012 

7454: 8003383228333308318358805377531888 8883838833300000000000000000033333 

7455: 8831375528338388285350815377502888 8881551532818004140104105071032000 

7460: 8033333223833388310350006377631000 0000000000008800000000880000030383 

7462: 1052841720018578110837046377660888 8868581628152088288857106888358338 

7464: 8800338228800000310360006377631008 0888888808000008000000088888833838 

7456: 0833333333333838888088000000000000 0005571220000000310350085377531000 

7470: 0033380220000000310360005377531000 0001354520142004200020015004043037 

7472: 0033533233002000200080503000331000 0000330333333088000000000000303333 

7474 : 800030022000300031 0350005377631 000 0001 3545201 4200420032001 500434 3037 

7476: 8803583233002000200001043000331000 0000000000000000000000000030838338 

7588: 6883888228888888310350005377631000 6001354520142004200020015004043307 

7502: 6333503233032000260000543000331600 8880888000000000033383383833833338 

7584: 6800300220003000310350005377631000 6040053520004000200050003515021014 

7506: 6030030000003838888888888888888888 0888888888888883388830888880030308 

7510: 600333822883883831836888B377631688 88488636288848832883B8388515021014 

7512: 6000383338838800300000000000000000 0000000000000000000000333388833338 

7514: 6333333220038333318368336377631888 004O3B522O0040OO2000EOO0O515O21014 

751 6 : 6033333300000033000000000000000000 0000000000000080000000000000033338 

7520: 6003330220000000310350005377631000 0040055220004000200050000515021014 

7522 : 6003333000000300000000000000000000 0000000000000000000000000033033000 

7524: 6803333:28833338318358885377531688 6843578628818572163353205377621811 

7525 : 6830033333833338888000000000000000 0000000000000000000000000003033333 

7530: 0033S3322833083031 0350006377631 000 0542011220033883285588815377523377 

7532: 8344453220330338280420015377520001 0000423232002000000377042002231 000 

7534: 6338833228833338310368885377631888 6888833250000000200360835377531030 

7535: 8345721228333830200000013000321001 0000577220010003030350405377531038 

7548: 6833333220033333310358005377531000 0054515520010003265377346377551014 

7542 : 0333300030033330000000000000000000 0000003333300000000030000000333338 

7544: 8333333228033000310350005377531000 0054515520010000205377346377551014 

7545 : 0003333388833838888000088000000000 0000000000000000000800000000000338 

7550: 0008333220000000310368886377531888 8354544528818888285377346377551014 

7552 : 6833333333333388800000000000800000 0080000000003000000000000000003830 

7554: 003883322333338831 835888S377B31 008 0054544520010000205377345377551014 

7555 : 0333333333833308888808080800088338 8883333333333888888888300000033333 

7550: 0838833228038888318358085377531833 8854238228318888285377405377661323 

7562 : 6833333333333833838888888888888838 6883888833838883883888330000333333 

7554 : 600333022088833831 8358885377631 688 6863838883888688888838888888883030 

7555 : 6303333388838888088888888888888888 0000000000003888338883388888883383 

7578: 688333322833800031 0350035377631 000 6000000000088833338388808883338838 

7572: 0333338383383888888888888888888888 6688888888888880888888888888833830 

7574 : 600300022000000031 0350005377531 688 6888888888838888838888888888833338 

7576 : 6888000000888888888688888866888886 6866888888888000000000006888880880 

7606: 668888822666680831 6366606377631 668 6888868880000000000000000000000000 

7602: 6800000000000000000000000000000000 6000000000000000000000000000000000 

7604 : 600000322003000031 6366886377531 688 6888888888880000000000000000000000 

7606 : 6000000008000800000000000000000000 OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO 

7616: 6688888226888888316368886377631 000 6800000000000000000000000888000000 

7612: 6000000000000000000000000000000600 6000000000000000000000000000000000 

751 4 : 663333822888883831 6358886377631 888 8825571 3201 571 402003542668324424 38 

7616: 6825571328157148266368546824242438 8828254528118848280041346377642430 

7626: 600000022000000031 0350005377531 OOO 0000000000038888883888888888800338 

7622 : 6833338333833338888888888888888838 0003333000000000000000000000000033 

7624 : 608838822883383031 0360006377631 033 OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO 

7626: 6883388888833388888888888800000000 0000000000000000000000000000000000 

7636: 6838888220000000316360666377631600 6848485226888866645368816377628377 

7532: 6881 37552881 8880205351 1 16377662000 00037176201 420062003605040025021 05 

7634 : 800000022000000031 6360886377631 883 884 1 1 3752888888884836881 5377628377 

7B36: 0887425528142005200350514002402105 0041305520000000200417005377720377 

7846: 6838888228838388316350885377631883 8883838333338868888888888888883338 

7642: 6883517228830030200350015377631000 0O0345722OO0S50O2OO350O0B3775O241S 

7644 : 603800022000000031 0350005377631 000 0000000000000000000000000000000000 

7646 : 6000000000000000000000000000000000 0000000000000000000000000000000000 

7656: 600000022000000031 0360006377631000 0000000000000000000000000000000000 

7652: 6000000000000000000000000000000000 6888388883333383888888888888833338 

7654 : 688888822888000331 0360005377631 000 6000000000000000000000000000000000 

7656: 6600000300000033088888000038888000 0000000000000000000033838888888888 
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7GS0: e00eee322030eQoa3i 03S0005377B31 000 0000000000000000000000000000000000 

7GS2: 0000000880000000000000000000000000 0000000000000000000000000080000000 

7£S4 : 600000022000000031 03B0008377S31 000 0000000000000000000000000000000000 

7BSS :- 6000000000000000000000000000000000 6000000000000000000000000000000000 

7S70: 600003022000000331 O3S000S377B31 000 0000000000000000000000000030000000 

7B72: 6000000830300330000000000000000000 0000000000000000000000000000000000 

7B74: 80300332208388303103B00CS377631000 00074B7B200000802003B001B377B31000 

7B7B: 004 1 72BS2000083320042000S377B22000 0000000000000000000000000000000000 

7700: 0000000220000003310360005377631000 0000000000000000000000000000000000 

7762: 6003300000000383800000000000000000 0000000000000000000000000000000080 

7764 : 600388322000083331 03B000G377B31 666 6000300000000000000000000000000000 

7766: 6003080003303330000000000000000000 0000000000000000000000000000000000 

7710: 6600000220003033310360006377631066 6001552520000000200360016463662200 

7712: 6081 41 0620000O0020O3E00O0420002143 6000000000000000000000000000000000 

7714: 6033000220000033316360006377531666 6000000000000000006666666600000000 

771B: 6000333383833338800000000000000000 0042B3BB20012B00200020006377720O00 

7720: 6000000220000033310360O0E377631666 6000000000000000068600000000000000 

7722: 6000000833883033330000000000000000 0001 1B363505OOO420536020637763240O 

7724: 6000000220000300310360005377631000 00255713200175S026037704B377642103 

7725: 6141553220000000205360016377620377 6640000260000000200417635377720377 

7736: 600000022000000031 0350005377631000 6000000000000000000000000000000000 

7732: 6000000000008803000000000000000000 6000437535050004071360206370432400 

7734: 000000022000083331036O00S377531000 002667132001 7550200377046377542103 

IIJ^'- glili55iil§0300O20536O015377520377 6040000260000000200417635377720377 

7740: 0000000220000000310350005377631000 6052223220010000205377415377551026 

7742: 6054604220010000205377415377551020 6043552520010572100352045377521011 

7744 : 600003022000003031 0360006377531 000 6660000000000000000000000000000000 

7745 : 6000000000000000000000000000000000 005 1 1 7722001 0000205377345377551 01 4 

7750: 0000000220000000316356006377631000 0051433626010000205377355377551614 

7752: 8054212226010000205377415377551020 6054544526010000205377346377551014 

7754 : 000000022000000031 0350005377531 000 6000000000000000000000000000000000 

7756 : 6033383333880800000000000000000000 0000000000000000000000000000000000 

7760: 600000022000333031 0360006377531 686 6600000000000000000000000000000000 

77o2: 6003000C00O00880330000000O0OO000O0 0000000000000000000000000000000080 

7754: 0003300220000330310350006377631000 0051765220014000205377355377661014 

7765: 06o421222001 0003205377416377551020 0040065220004000260060000515021014 

7770: 000000022000000031 0360005377631 000 0000000000000000000000000000000000 

7772 : 6000000000000000000000000000000000 0000000000000000000000000000000000 

7774: 0003383228833388310358006377531688 8000000000000000000000000000000000 

7776: 0000000000003000006006800000000000 0000000000000000080886866668868660 
16080: 8800000220000000316358005377631668 6601705520000000288726815377532200 
16002: 6000000000000000068868886886008860 0000000000000000000000000068800000 
1^22^= g§23405220150540268351355815442ie6 6800000220000000310350005377531000 
10636: 6703352620000440205360015377512860 0000000220000000316358806377531030 
10010: 6600000220000000310350005377531666 6680675S200120OO2053S10S5377532200 

10312: 6000000000000000000000000000000000 6800000000000000000000000000000000 

J§?^' 5^55^IHi80^ 2000205351 055377532200 660000022000000031 0360006377631000 

Jf^ll- fi§§£§§iig§§g5Si2}g3§003E377631600 00000032280O000C31 0350006377531 000 

}§Si?= f f f §S2ii^ggSg?522k5?§^03S377631 000 6000575620012003205360555377532200 

\^^r §5S^?§2§§§?§2§5§25§§§2^0002®0000® 0000000000000000000000000000000000 

}fi^^- Sgg?|"B20012000205350S56377S32200 6000000226000000310350005377531000 

16025: 6000000220000000310360005377631000 0000000226688000310350005377531000 

}f^?= gg§§ggg22000000031036O006377531000 00S3107620150540150il356W 

10^2: 6000000000000000000000000000000000 6600000000000000000000000000000000 

}^^'' g§iiigiiiiiififli}fiS00§S3^5316OO 600000022000000031^^^^ 

\ §i?|- Sf §??????§§?555£5k03S000S377531 666 666680022000000031 0350005377531 600 

Jlf??= 6601155520010000205350556377502445 6201115220000000030360016377612000 

\^l^? ^gU}iiifl?2§S0§20360016377612000 0201115220000000200360010420012000 

}§2?^= 8201115220000038200350010420212688 6261115228800000200360010420412000 

ISS^i-' 0201115220000033200360018426612660 0201115220000000200350018421812000 

J§^= SiiHifill^g^Sg5?g5^S001®^212126e0 0201775520000000288358888421412800 

Jf^?= 6601151220000000205350016377502487 6842002621000000268668813886328377 

Jf^= gi^SS71 3201 531 401 50377006000250377 004404222000000^08446665377526375 

ll'^t f30?305220000O002OO350O15377531686 660260022100000^00000013000302205 

\l^i'- f3^$551220022000200363552277421375 00044475200000002883588822766^288 

18052: 664115BB20010803205352B55377620377 022204332015114K08351346857252000 
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1101 Zi 0041375520012000205352055377520033 002247122001255026037700S377S42C01 
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1 1 ei 4 : eeSES71 32801 35702e23B000E377B42453 214 32572201 404 £0200420008000021 000 

1101B: e044ieS5201000302023S030B377Eei023 000e30332014208720007730S377B024Bl 

1 1 020: 0044 1 071 201000302023B00063776B1O23 80003033203O3O032003B0006377631 000 

11022: 0O0BB713200135721003B000B377602410 0031313220000CO0200440006377B02410 

11024: 800BB71 32001 31 702003S000S377643034 0003203S2001B57020002000S377B02410 

1 1 026 : 800SS71 32001 31 7028036000B377643034 003320322031 E57020002000S377E024 1 

1 1 030: 800200322001 00032053B405B377B02000 002342522001 B53020037780B377B02083 

11032: 002231 7E20010038200057110501431003 0001B72B1 0032000033377240500031 023 

11034: 802231 7B2001 03032000571 10501 431 000 0001573210002008030377240508031033 

1 1 03B: 832231 7B2831 0030200057110501 431030 030167521 0832008030377240500331 030 

11040: 8822317528810030288057118501431800 0001675610332098038377246500031030 

11 842 : 802231 752001 000020885711 8581 431 888 8881 67BB1 8332008838377248588331 030 

11844: 8822317528818880288857118581431888 8331677218832888838377248508331800 

11 84B : 832231 762831 80332800571 1 8501 431 883 8831 677B1 8382030030377240500831 033 

I 1 050: 082231 762001 08032088571 1 0581431 888 8881 78861 8882000330377248588031 030 

1 1 052: 802231 762001 00332000571 1 8581 431 003 0001 781 21 8882800330377248588831 830 

11054: 8022317620010033280057118581431883 880170161 0002008838377248580031030 

11856: 8042317620000308288368818421222883 4583148628802448830377046377682185 

11858: 8888185522882808288437810408802000 888371462814288B8783S184488240218S 

11052: 08011BB52000883828S3B8816377B82487 2481374B28808000200448806377B12000 

11864: 0032861528000030205350015377602455 0341521232004800200360002877520377 

1166S: 003B671 320081 878288377006377B31 888 8081113228888888288448806377612300 

1 1 078: 883SB71 328881 07020037700S377B31 808 8881 1 1 3628880088288448886377512000 

1 1072: 0034 1 21 5201 0002020037700B377B31000 88821 4872881 7578288377885377543333 

11874: 8833427520000000200360016377531000 0087575222832800200837008501531830 

11076: 8888243228883333280360015377631888 884821BB2814280O2881B8886072260377 

11188: 0000243220000038288368816377631808 8881425620142000200377884872282413 

11182: 8882871528383388288368815377631808 8842713B2888847828836888B377658377 

1 1 1 84 : 080024322000003328836881 5377531 000 8881 551 522802888288237886377531 883 

11185: 0883243228883838200360016377631000 0881551528824838288237886377603386 

11118: 8838243228888838288358815377531088 8884453228888333283368886377631808 

11112: 0333243228000333280360016377631000 0004452220003000200350006377631033 

11114: 003324 322883333328836881 6377B31 888 8334454228333338288368885377631 333 

HUB: 83334 2362830033028835881 B377531 088 8858331 2200000007214200063602321 00 

1 1 1 20: 000745522000333320036001 5377531 000 084 32775288846832323600241 8868201 5 

11122: 0037455228333088280360815377631000 0000402620038338281368326181031033 

1 1 1 24 : 883353322333033328035001 5377631 888 83424 1 8628335688280360006377520033 

1 1 1 26 : 000353322333333328836881 5377531 888 834241 26283334 78288368836377658033 

11138: 8333533223333833280360016377531000 0042418628836548288350036377620033 

11132: 8832311623833303280360816377531000 0002410520006603200377006377B71038 

1 1 1 34 : 033231 1 52333333320035881 6377631 000 00024 1 2620083470288377835377631 838 

1 1 1 36 : 003231 1 62833338328836001 6377631 888 80024 1 0620006548200377005377571 000 

11140: 0042716221000333200000013883320376 8831571621488888288888003880332400 

11142: 0322317520012803320377016377531898 8883388268883838030358836377502486 

11144: 8831537228832033205375755377531000 2304512220888880288350880501512000 

1 1 1 45: 0004 1 1 25201 40330200377046831031 000 0000003328888800200350005377531 038 

11158: 0040473220000308212360015377602011 00220B55B001 51 421 00376575377603031 

11152: 0040575728011172102350546377621011 0001415228388880200350005377531000 

11154: 0040504720011172102350545377621011 80S02472200120000803S0B46377B61015 

11156: 004657732881 11 721 82360S46377521 011 0001416520000000200350005377531000 

11160: 0040505320011172102350545377621011 8868251228012000000360545377661015 

11162: 0002221222002030200360500515031008 8882221222882888203350708515831803 

11 164: 0833547228033333288368838514283885 8888647B2888G03O200360000S1420308B 

11165: 0348323528330388285353885377631883 8041 1335200O80002O535880S377531 000 

11170: 0001710520000033288363888514283005 0001711220000000280350000514203035 

11172: 0002221222002000200352640516031000 0000077222002000200350508516031000 

11174: 0303003228338478288368385377542831 0888833258883888280350035377531883 
11176: „ 8040000250000000201350836371520001 0040000260000000281368036371482485 

}\l^'- 5|^ft5giif3L^iggi?lS?557403782000r 0883833000000000000088800080880000 

11202: 0000000260022000200352078484402022 0007431620022000200362000404482022 

\H^^'- §g2?2??2S8eBe8332e0360036377531000 0000000000000000000000080000000000 

11^06: 004BS53521888333S70088883888321372 0833237328331483288368886377603005 

11210: 0003287328831483280350006377683005 000020732000140^00360006377503005 

11212: 033828732888148820035080B377B0300S 0000207320001400200350005377603005 

11214: 8000207320001400200360086377503005 0448388272828888283377176777512883 

11215: 8448033272828803283377335777512080 80022212220020002003S420051B031000 

11220: 83312372231 42830200257505370431000 8081287228142838288257585378431888 

11222: |848242628883833202360085377B31088 80415426200000002023503^37^^ 

Hi?^= f2^ll^?ii^5S^225??2255540516031088 8833888272882838200020576377531003 

H^ii= lf?i?iiiiifgigg^g^git^^lE831088 8832768223832803878017003000331000 

Hiif ' 11^?} ?iii§??g55^5^i0^^377531 088 8002221 22200200020035314051 6031 000 

HIir* Sfl^H?ilgUg§^§?g§l§§§*^^^137B 0002120620018888280360540502002410 

Hil^' fSf?f?4ii?§ig5§iig9360540502002410 0040574720011172102360646377521011 

WlfV i§§i^mi?ff?ggg^§^§50^377631000 0000000000000000000000000000000030 

Hl?§' f§??f?^iiii2^55§^5936060O51 6031 000 0000077222002000200360700516031000 

11242: 0041513620000033288888803000321002 0004103520140000200360006035052000 
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11244: ee2155S32eei7SSe20837G2e5377S3008e 0800546520888808208358080514203608 

11245: 0880000080800008888888888888080000 0001707520008888288368888514283885 

11250: 0808000080000800000000000000000000 005557132001 7170122377005377502405 

11252: 0021 5545201 5200800037700S3704O3045 0855571320017170122377005377702405 

11254: 1140017520142000000437005370520377 0004105120140000200360005035052000 

11255: 0021 55532001 755020037520S377G30000 0020287328813178288837005377503007 

11259: 0002143S1G80888420135800537040224G 0020207320813170200037045377503087 

11252: 0002143515080004201350885370402245 08802073200814002003S000S37750300S 

11264: 0000080000000000000000000000000008 8858753220010000205377416377651020 

11265: 00E6476S2OO1 0000200377502204021020 0046000250142005280350574037020001 

1 1279: 9000000000000008000000000000000000 00400002601 42005200350574037020001 

11272: 9000000000000000000000000000000000 0000000260000000200360035377631000 

11274: 9000000000000000000000000000000000 8040518520000000200350010504221375 

11276: 9002125220000000030350005377602420 0003123220005500200360005377602415 

11300: 9040571720011172102350545377621011 0041420520005000010350005377521015 

1 1302: 9000000000000000000000000000000000 0006671 320001400200350085377603005 

1 1304 : 9000000000000000000000000000000000 0066671 32001 7170122377005377520003 

11305: 9021554520152000000377006370403046 00SS5713200171701223770O537772O0O3 

11310: 1 1 4001 75201 42000000437006370520377 004057572001 1 1 721 02350546377521 01 1 

11312: 9001421228888880200360006377631000 8004053220010000200350540502002410 

11314: 9040757720011172102350646377621011 004005322000500001 0350005377521 015 

11316: 9002317520012000020360016377531000 9000000250000000030350035377582406 

11329: 9040518520000000200360010504221375 9902124520000000030350005377502420 

1 1 322: 094 655362000080021 235001 5377603000 0004556620000004 1 4070000606301 2000 

1 1 324 : 900230722001 00002003505405020024 1 0000000000000000000000000000000000 

1 1 326 : 90044 1 1 22901 00002003805405020024 1 0000000000000000000000000000000000 

1 1 330: 9064 1 542201 1 0050200020546377661 376 0000000000000000000000000000000000 

11332: 5241555320081440205350005377621377 0041371520000000202360005377631000 

11334: 9000000000000000000000000000000000 0002221222002000200360500515031000 

1 1 336 : 9000000000000000000000000000000000 0002221 22200200020036254051 6031 000 

1 1 340: 9000000000000000000000000000000000 0082221 222002000200361 04051 6031 000 

1 1342: 0000000000080000000000000000000000 0002221222002000200360540515031 000 

11344: 9000000000000000000000000000000000 0000000261000000200000032000002200 

11346: 9000000000000000000000000000000000 0002221222002000200360600515031000 

1 1 350: 9000000000000000000000000000000000 0002221 22200200020036240051 6031 000 

11352: 9000080000000000000000000000000000 0002221222002000200352500516031000 

11354: 9000716632000000200360000511003034 8046653520000000212360016377603001 

11356: 9000000250000004140720035053212888 8856671328817170122377006377602405 

11360: 8021564620152000000377086370403046 0000000000000000000000000000000000 

11352: 00S5571320O17170122377005377702405 1140017520142000000437006370520377 

1 1 354 : 9000000000000000000000000000000000 000403722001 00002003505405020024 1 

113BS: 0000423S20000000200350010523232200 0803201221000000208000003000302205 

11370: 0000000000000800000000000000000000 0001552620000000200350010403002201 

11372: 0024376220150000200375444052002012 0000000000000000000000000000000080 

1 1 374 : 0007776220000000200350005377631 000 006335553301 200020000001 3000350000 

11376: 9002306520010000200360540502002419 9900000000000000000000000090000000 

1 1 408: 906335553301 200020000001 300O3S0000 90021 1 752881 00002003505405020324 1 

11492: 0063365533912080299000013000350008 9063337620812572100440005377602410 

11404: 905335553301 200020000001 3O003S0000 0082121220810000200350540502002410 

11406: 9053355533012000200000013008360008 0003555528812572180448685377682418 

11410: 98S81 3872001 51 421 00361 000523621 376 604C325532002OO020737500S77763100O 

11412: 90601 3072001 51 421 00361 00S523S21 376 0041457632002000207375205777631000 

11414: 0022317520012000020377055377531000 0061277620012000030377046377720000 

11416: 0022317620012000020377055377631000 0080800268888800030350036377602406 

11429: 9022317520012000020377056377531000 9000000260000000030350036377602405 

11422: 9001166520002800205377055377631000 2301065220000000200420000581412000 

11424: 9001 155620OO20002O537705e377S31000 2301055520000000200420003501412000 

11425: 900275472001 75E020837704S377B43033 0OS3e33S2001S5302003770OS377S20377 

11439: 1704157520102215400350000501452000 0020000320154320505377005377632200 

11432: 17041711201022154003S0000S01 452000 0020000320154320605377006377532208 

11434: 1042041720000000110540005377620377 0044222220142006200157303007550000 

11436: 0004141520000001600420606377602430 0000003310004002500350002000422200 

11440: 054201 122C0OOO00205500016377620000 0041554520102330208020004377560017 

11442: 00441725201400002003S00OS014G61375 0040000320102050200140000502051376 

11444: 90441161201400OO2003S800BO146B1375 0040000320102050208148800502061376 

1 1 446 : 9022071 52001200020035051 0507242434 00081 255321 42370600377242001 431 000 

11459: 0022071520012000200360510507242434 0000127232142370600377242002631000 

11452: 9022071520012000200350510507242434 0040126532142370600377244377620005 

11454: 0022071520012000200360510507242434 0040127532142370603377244377620013 

1 1 456 : 000557 1 32001 1 1 721 003600063776024 1 O OOOOl 5552001 2000200522400501 431 600 

1 1469: 900SS71 32001 1 1 721 003500053775024 1 00001 5722001 2000200522400501 431 OOO 

11462: 9000000000000000000000000000000000 0000800000000000000000000088000000 

11 464 : 9000000000000000000000000000000000 8000000000000000000000000000000008 

11466: 0880000000000000000000000000000000 0000000000000000000000000000600000 

1 1479: 9000000000000000000000000000000000 0000000000000000000000000000000038 
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1 1 472: eeadeeoaeeeeeeeeeeeoeaeeeeeaeaeees eeeaeeeaaeeeeeeeeeeeeeeeeaaeeeeeaa 

11474: 6380033828898888980800808008809808 0000808800008000000088800000000008 

1147E: 0088000000000000000000080000000008 0000000000000000000000000003000030 

11500{ 6000030000000300000300000000000000 000000O000C30000000000O0000000O000 

11502: 6000008000008008000000000000000000 0000000000000000000000000008080000 

1 1 504 : 0008000000800000000000000000080000 0000000000000000000000000008000000 

11505: 6008000000080000000000000000000008 8000000000000000000000000000000000 

1 1 51 6: 6000080000000000000000000000080000 0000000000000000600000000003000000 

1 1512: 6000000000000000000000000000000000 0000000000000000660000006600000000 

1 1 51 4 : 6030003000000000000000000000000000 6000000000000006660666666660000000 

11516: 6000000000000000000000000000000000 6000000000000006660666606666600000 

1 1528: 0000000000000008800000000000060060 6000006660000006666666666666660000 

1 1522: 0003000000000000060000000000000000 6000030000000006666666666660000000 

1 1524 : 6003000300000000000060660000066660 6000000000000006066606666060086000 

1 1 525 : 6003000300300000000000000000000000 6000000000000006666666660660000000 

1 1536: 6000000000000000000000000000000000 6000000000000006666666666608066888 

1 1532: 6888800000000000000000000000006000 6688888888866666666666666666668000 

11534: 6000003000000000000000000000000060 6080000000000666666666666668000000 

1 153S: 6000000000000000000000000000000000 6600000066666666666660006000000000 

1 1 546: 6000000000000800000000000000006600 6660000600666666606660666600000000 

1 1 542 : 6000000000000000000000000000000000 0660000066066666666000666600000000 

1 1 544 : 6000000000000000000000000000000000 6666000006666666666666666000000000 

1154S: 6000000000000080000000000000006600 6600000000066666606066866600000030 

1 1550: 6000030000000000000000000000000000 6666000000666666606000000000000086 

1 1552: 6000000000388030000000000000000006 6668800660666660660066666660000000 

1 1 554 : 6000000000000000000000000000000000 0600000000000066606600060000000000 

1 155G: 6000300000000000000090000000000000 6608000000000000006666866000000000 

1 1 5S0: 6600000000008000000000000000000000 6600000666666006666666000000000000 

115S2: 602348522015O5402003E135BO1544210S 6023405220156546266351355615442165 

11564: 6030030250000000200360035377631000 6666600266660660266356635377531686 

1 1 555 : 6880883000008880000000000000000000 6888880000006666660666000000000000 

11576: 6000000250000000200360035377631000 0000000250000006266356635377631600 

11572: 0023405220150540200351355015442165 6023405220150546266361355615442185 

11574: 6C8138722888883414674668S853462627 6888880250000666268350636377631638 

1 1 576 : 6888888256000000266366636377731 666 6 666686256666666266366636377631 000 

11666: 6040000250142006266366634637626661 6688868000660666666666666666006000 

11602: 6000000250022000266352076484462622 6007431620022000200362666464482022 

1 1 604 : 6000207320001 4 002003S000S377663665 6688880000000008066666000000000000 

11505: 6846883251 888000200800333066321372 6000207320001406260350005377603005 

11516: 6033207320001400266350686377663665 0003207320001406266356885377663005 

11512: 6080207320001409200350005377503005 0000207320001400266356605377603005 

11514: 6080207320001 400200366005377663665 6800000000000000080900066666666880 

11515: 6808000000000000000000000000000666 6023405220150546266351355015442105 

11520: 6001207220142000200257505370431668 6801207220142000200257505370431000 

1 1 522 : 004 1 544 620080000202350005377631 668 6640507520066600202356005377731 000 

11524: 0023405220150540200351355015442166 6868688272662668260020635377531000 

1 1525 : 66234652281 58548288361 35581 54421 65 6601 34052300206020001 7663000331 000 

11630: 8605571320001400200350005377563685 6623465226158548268361355615442106 

11532: 0001713620005000200350000501462465 6604500223682686266886563688331683 

WUt'' filtlfiiiH2^§flig§§]LZSf^§5523ie66 6668868886668868668666800000000000 

11635: 6880000000000800000000000000000000 6668000000000006668666680000000000 

11540: 6623485226150540200351355015442105 6623465226158546268351355615442186 

11542: 6841514528868883268686683668321662 6664184126146666200350005035052000 

1 1644 : 6621 55532881 7556288375285377536666 6668868256666668268356835377631 888 

1 1546: 6600003000000000000000000000000000 6888888266666688286350035377631 000 

11550: 6000000000000000000000000000000000 6665571328617176122377666377602406 

11652: 0021303520152000000377605376563646 6065571326617176122377805377702406 

11554: 1142044520142000000437065370726377 6000000000000000000000000066680000 

11556: 6030000000003000000006000000600006 0020207320013176266037006377603007 

11550: 0032143515000004201366605376402245 682628732001 31 70206637646377563007 

11662: 0002143615000384201356005376462245 6688287328881468286368865377663885 

11654: 6388000000000038866668688000000666 6658752626816686265377415377561628 

11665: 605047552801 0000200377562264621626 6846888256142685260356534637626001 

11570: 0000000000000000000000000000000800 0040000250142005266358534637626831 

11672: 6033800033803030000000000000000000 0000000250000000266366636377631600 

11674: 0000803000800030000000000000000000 5344550220000003261366005370421375 

1 1 675 : 0030038388333000000000000000000000 00031 21 2200056002663668853776624 1 5 

1 1 768: 6808333000000000000000000000000000 0000000000000006606066666680000000 

11702: 0808000030000000000000000000000000 0005671320001466266356666377663635 

1 1 764 : 6000000308808003000000000000000000 0055571 32901 71 78122377605377620003 

11705: 0021203520152008800377005370603045 6055571326617176122377666377726883 

11718: 1142844523142833838437605376728377 6668686666686668606666686866800000 

11712: 0000000000000000000000000000000000 6600044623002060200000003000331 000 

11714: 0008080000000000000000000000000000 0000000000000000000000000000000009 

11715: 0000830000000000000000000000000000 6000000000000000000000000000000000 

11720: 0033360000388388888888888888880000 0000000000000000066666660000000000 



4,887,235 
661 662 

11722: 9883300288808283808008880000808009 0000080000003888888000000008888898 

11724: 008^57E523882883288808883838331000 0000000000000000003088888888800000 

1172B: 0080325223002080208300503008331800 0800030000083883888838800000000000 

11730^ 00033S5B233855432e33S883S377E71800 0000000030003000008000000000800000 

11732: 524] 5E53200014402053E000o377B21377 0041 37322000338328235000B377S31 000 

11734: 0883888833C00833338388888388888388 03234052201505402003B135B01544210B 

11736: 0080200083808833308833883830000000 00234052201505402083B135B01544210S 

11740: 0038083333300033338800000000000000 00234052201505402003B135B01544210S 

11742: 0083383383330688838383888833888388 002340522015354820035135B01544210S 

11744: 0083803388083888383833333800030000 00234052201505402003B135B01544210B 

1174B: 0000833388300000333008800000000000 00234052201505402003B135B01544210B 

11750: 0038880003000000000000000000000000 00234052201 505402003B135B01 54421 0S 

11752: 0000000008000038883800000000000000 00234052201505402003B135B01544210S 

11754: 8084020232000033288360010511003041 0001 172S200120002053B070B377631 000 

1 1 75B : 0000380000000080333388833330000000 0056671 32001 71 701 2237700B377B024 06 

117E0: 0021 3036201 5200000037700E370B0304B 0000000000000000000000000000000000 

117E2: 00DSE7132001717012237700E37770240B 1142044E2014200000043700E370720377 

1 1 7E4 : 0008833838338000000000000000000000 000002522300200020301 7003000331 000 

11765: 0080080080800338333838883883388880 9000000080008000000000000000000000 

1 1 770: 0000000803883338333883388883883880 00044B42320020002003B0550402E31 000 

11772: 003362562014046020037E54E007631009 8000000000000000000000000000000000 

11774: 0004464220000000200350016377631000 00020B57201414E020037E54E004231000 

11775: 8O2437E22015000020037E4440520O2O12 0000000000000000000000000000000000 

12000: 0900900090000909999909999090990999 9990000000000000000000000000000000 

12002: 9008000000000000000000000000000000 9000000000000000000008888388803388 

12004: 9000000000000000000000000000000000 9000000000000088338888388838383383 

1 2005 : 9000000000000000000000000000000000 0000000000000000000000000000003030 

12310: 9000000000000090000000000000000000 9000000000000000088883338838338388 

12012: 9008000008000030000000000000000000 9000000000000000038088883838888338 

1 201 4 : 9900000000000000000008080800000330 0000000000000000003388338838830033 

1201 B : 9000000000000800000080000000000000 0080000000000000000080000000008030 

12020: 0008000000000000000000000000000000 9900000038008800088803038888333338 

12022: 9003000000000800000000000000000000 0000000000000000000000000000000833 

1 2024 : 9900000000080000000000000000000000 0000000000000000000000000000003800 

12026 : 9000003000000000000000003000000000 9900000000000000000000000000000(^00 

1 2039: 9900000000000000000000000000000000 0000000000000000000000000000000000 

12032 : 0990000000000000000000000000000000 9900000000000000000000000000000000 

12034: 9900000000000000000000000000000000 0000000000000003000000000000038338 

12036: 9000000000000000000000000000000000 0000000000000000003333888388838888 

12049: 9900000000000000000000000000000000 0000000000000000000800000000000303 

12042: 9000000000000000000000000000000000 0000000000000000033338833838333333 

12944: 9000000000000000000000000000000000 9000000000000000000000000000000000 

1 2046 : 9000000000000000000000000000000000 9990000000000000000000000000030000 

12059: 9000000000000000000000000000000000 0990000000000000003000000000000000 

12052: 9000000000000800003300000000000000 9000000000000000000000000000000000 

1 2054 : 9900000000000000000000000000000000 0000000000000000000000000000000000 

12056: 9000000000000000000000000000000000 0000000000000000000000000000000000 

120S0: 9008000030000000000000000033388338 0000000000000000000000000000008000 

1 2052 : 9000000000000000000000000003000000 0000000000000000000000003000002000 

120E4 : 9000000000000830000000000000000000 0000000000000000000000000000003388 

12055: 9000000300000033888338388838888838 0000000000088883880000000000000000 

12070: 9000000000000000000000000000000000 0000000000000000008000000000000000 

12072: 9000003300000000080000838888388333 0000000000000000000000000000009000 

12074: 9000000000000000000000000000000000 0000000000000000000000000000000380 

1207o : 0000003000000000000000000000000000 0000000000000000030000000000000000 

12100: 9000000000000003338888833388338880 9900000000000000000000000388888388 

1 21 02 : 9000008000000000088883383383330000 0000000000000000083838300000000000 

121 04 : 9000003000000000000000000000000000 0000000000000000030000000000000000 

12105: 0000033800000000000000000000000000 0000000000000000888838888833383383 

12110: 9033000000000000000000000000000000 0000000000000000000000000300000000 

12112: 0000300930338330000000000000000000 0000000000000000000000000000000000 

121 14: 0080000000000000000000000000000000 0000000000000000000000000000000000 

12116: 0300800000000000000000000000000000 9900000000000000000000000000000000 

12120: 0008833000000000000000000000000000 0000000000000000000000000000000000 

12122: 9000800833333338333338888838338388 OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO 

12124: 9080000000003030038388883833888388 0000000000000000000000000000000000 

12125: 9008000838333388383888833338883338 0000000000000000000000000000000000 

121 30: 9000300000003000000300030000000000 0000000000000000000000000000003000 

12132: 9000030000000080030080000800000000 0080300000000000000000000000000330 

121 34 : 0000000000300000000000000000000000 0000080000000000000000000000000038 

1 21 35 : 0003000000000000000000000000000000 0000000000000008000000000000000000 

12140: 0038338883833383888838338888338880 0000000000000000000000000000000000 

12142: 0033833838333838888888388833383833 0000000000000000000000000000003888 

12144: 9083833388833888838888833338388883 0000833888888888038888833883833338 

12145: 0383388383883883838833338333838888 0000000000000000000000000000080000 

121 50: 0003033833333833888883383838838888 00000000000O00000000030000000G3O00 
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1 21 52 : 888600 8098000003300900000088000000 0080808000000880000000600000000000 

121 54 : 8800088088800880800000000000000009 9000000008000000000000000000000000 

1215E : 8000000000008888008000000000000000 9000000000000000000888000000008800 

121 89: 0000000000000088800808000000000009 9990000000000000000000000000000000 

121B2: 00002272220020002003S0SO65ieO310O0 9988227222902000200350700515031000 

121E4: 00821 11B200003002003B000051420300B 0002112B200O000O20O3B0OO051420300B 

1 21 BB : 000035 1 B2008C00020O36O0eB377B31 999 0031 51 5B2000000O2003BOO9B377B31 000 

12170: 00821 11B200000002003BO0O05142939OS 8002112620O00O002O03BO0005142O300B 

12172: 000022722200200026O3B2B4051B031090 9905571 320001 4002093B9OOB377B03005 

1 21 74 : 0007 77B22000838820O3B000B377B31 000 00000002B00O00O02833B993B377B31 900 

12175: 90000088000000000O9000e990OOO09099_9003000O0999999900096009O909990000 

12280: 0049999289142095288358734037828881 8999999900998890989889088888888999 

12292: 80000002S00220002083S2870404402022 0007431520022900200352000484402022 

12204: 00000802B0OO000O2003B003E377B31000 0000C00C0OOO00O00000OO880000000000 

1220S: 0O4BB53B210O0O035700000O3000321372 8041547521000000570008003000321371 

12210: 0000207320001400200350005377503095 00O020732099149020035000S377B03005 

12212: 0000207320001 400200350005377603005 0000287320001400200350005377503005 

12214: 0000207320001 4002003S0005377S03005 0400227520000000209350000501512000 

1221B: 044000027201B992103377335777552000 8880227222982909299354288515831000 

12229: 0030405520042001 28O25750B377631000 0000405529942991290257595377531900 

12222: 8940512520000000292359905377631099 0942995229090099292359995377731999 

12224: 8950345533912909299090502000050009 0090900272092990299020735377531000 

12225: 0000227222002000200362440516031000 0090000999999999909900000000000000 

12230: 0000000000099990000000000000000000 8800227222082888288353140516031000 

12232: 0000000000000000000000000000000000 0000900000090000000000000000000000 

12234: 8800000000000000000000000000000009 0099900009900000000000000000000009 

12235: 0900000000000000000000000000000000 0000000009999999990000000000000000 

12240: 0008571320001400209369996377503005 0005571320991400200360085377503005 

12242: 0041033520000000200000003000321002 09941045201400002003S000S035052099 

12244: 0021555329917559200376205377630000 0004226220000999299360000514203005 

12245: 0000000000000000000000000000000000 0004225220000000200360000514203005 

12250: 0000000000000000000000000000000000 00S557132001717012237700S37760240S 

12252: 0020421520152000000377005371003046 0055571320017170122377006377702405 

12254: 11^1205520142000000437005371120377 0000000000000000000000000000008000 

12^55 : 0000000088000000000000000000000000 002020732001 31 70200037005377603034 

12250: 00321 43B1 6000004201350006370402246 0020207320013170200037045377603034 

12252: 0032143516000004201350005370402246 0000207320001400200350005377603005 

12264: 0000000000000000000000000000000000 0050751620010000205377415377651020 

12256: 0060475520010000200377502204021020 0040000260142005200350734037020001 

12270: 0009800000000000000000000000000000 0040O002B01 42006200360734037020001 

12272: 0030000000000000000000000000000000 0000000250000000200360035377631000 

12274 : 0030800000000000000000000000000000 0000000000000000900000090999800000 

12276 : 0003000000000000000000000080000000 0004 1 01 5201 00030200377505377631 000 

12300: 0000000320000000200350005377631 000 0000000000000000000000000000800000 

12302: 0000000000000090000000000000000000 0005571320001400200350005377503005 

12304 : 0008300300000000300000000000000000 00BBS71 32001 71 70122377005377620003 

12305: 0020421620152000000377006371003046 00SB671320017170122377005377720003 

12310: 11^120|E20142000000437005371120377 0000000000999000000000000000000000 

12312: 0000000000000000000000000000000009 9999999999999900000000300000000000 

12314: 0033388300000000000000000000000000 0000000000000000000000000000008000 

12315: 0000000000000000000000000080000000 0000000000000000000000000000000080 

12320: 0000000000000000000000000000000000 0000000000000000000000000000000000 

12322 : 0000000000000030000000000000000000 0000000000000000000000000000000800 

12324: 0000000000000000000000000008800000 0000000000000000000000800000000880 

12325: 0000000000000000000000000000000000 0003000000000000000000000000000000 

}ill§' 0000000000030080000000000000000000 0000000000000000000000099999999900 

12332: 0000833888888838300000030000000000 0000000000000000000000000000999999 

}iii?= 5§00000000000000000000000000000000 000022722299299920035050051 sosiooo 

Hlfl' £f£f52^2§5^222S255®®0®^00000000000 0000227222002000200352540516031000 

12340: 0000300300003000300000008000000009 9900227222002000200351 040516031 000 

}ii??= f§^ii§i§§f§S§§§§§S5500000000000000 0000227222002000200350540515031000 

Jii?^= 0000000000330000000000000000000000 0000800000000000000008000000000008 

12346: 0000000000000000000000080000000000 0000227222002909200350508516031000 

12350: 0000003888000000300000000008000000 0000227222002000200362400516031000 

Jill? = 0000000000000000000008000000000000 0000227222002000200362500516031 000 

12354: 0041137620000003040360015377620377 0043425620000003200400010400020000 

\IMI' 0944405221010800200002042000020000 005BB71 32001 71 70122377006377602405 

\l& 0020$2152015200000037700S37100304B 0000000000000000000000088000000000 

}^W- KIUIiSgk^lZgl22377005377702405 1141205B20142OO0000437006371 120377 

123o4 : 0080000000000000000000000000000000 0000000000000000080000080000000000 

}ii?|- 0000000800000000000000000000000000 0000000000000099990000099999999999 

\Ul^'' Sf££S2S55S5553§3®00000000000000000 000^376222902000200375500402431000 

12372: 0000000000000000000000000000000000 0000000000999999999000000000000000 

\W,i'' fl2ii^^220000O0020O360Ol 6377631 000 0024376220150000200375444052002012 

12376: 0000000000000000000000000000000000 0000000009000000000000000900000000 
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12400: 0000000000000000000000008000000000 0000000080030060000000000000000000 

12402 : 0000000800000000000000000000000000 0000000008800009008000080000088008 

12404 : 8000000800000000000000000000000080 0000008888888008088888888080088880 

12408': 0000000830008000000000880088000000 0888888888000000080888800000000088 

12418: 0000008800800800000000000800888880 8808888880888808638088300000880888 

12412: 8888888888080000000000000000008888 0886888888880888080000000000888388 

12414: 8880080330000800000000008000000080 8008038008000008000000000600800800 

1241E: 8000008830030800000000000000000880 0000888888880000800030000000888880 

12420: 8608388380888800000000000000000000 0088888888838000080088888888888038 

12422 : 0088000808800800000000000000000000 0000000000800080000000888888808888 

12424 : 8000800000000000000000000300000000 000O03000OOO000O8O0000080OGOOO8888 

1242B : 8000000000000000000000000000000000 0030000000000000000000000000308838 

12430: 8000000000000000000000000000000000 8000800000000000000000000000033880 

12432 : 8000008888888800000000000000000000 00000888888800000800000008^0883383 

12434 : 8000008000000000000000000000000000 0088888808000000000000000000888083 

1243S: 8000000000000800000000000000000000 0008000000000000000000000000883888 

12440: 0000000000000000000008000000000000 0000000000000008000000000000883383 

12442 : 8008800000000000000000000000000000 0000000000000080000000000008883380 

12444 : 8880000000000000000000000000000000 8800000000000000003000000088883888 

1244S: 8000000008000000000000000000000000 0000880000000000000880000000888880 

12450: 8000000000000030000000000000000000 8000000000000000000000000000000880 

12452: 8000000000000000000000000000000000 8000000000888000000000000880000000 

12454 : 8000000000000000000000000000000000 8000000003880000000808000000000000 

12455: 8000000800008800000000000000000000 0000000000000800000000000000000000 

124S0: 8000000000000800000000000000000000 8000000000000000000000000000000800 

124G2: 8000000030000000000000800000000000 0000000000000000000000000000000000 

12464 : 8000000000000000000000000300000000 8800000000088000003000000000800000 

1245S : 8800080000000000000000000000000000 8800000000000000080030800000000000 

12470: 8000000000000000000000000000000000 0000000000000000000830000000300380 

12472: 8000000000000800000000000000800000 0000000880088880008888880380008030 

12474 : 8000000000000000000000000080000000 8800000000080000000080000000008300 

1247E : 8000000000088800000000000000000000 0000000000800000000000000000000088 

12500: 8000000000000000000000000000000000 0000000000000000000008000000083080 

12502 : 0000000083008880000000000800000000 0000000008800008880000000000883300 

12504 : 8088880088883383000000000800000800 0000000000000000000000000008883883 

1250E : 0000088888888000000000000080000000 0000000008880000000000000000008838 

1 251 0: 8000888888888380000000000000000000 0000000000000000008000000000888830 

12512 : 8888888888883380000000000000000000 0000000008300000000000000000883080 

1251 4 : 8000000000008330000000088000000000 0000088000000000000000800008888330 

1251B : 8003000800008000000000080000080000 0000830000000000000000000008833338 

12520: 8003883800000000000000000000000000 0000000008880000000080000000888888 

12522: 8888888888888300000000080000000000 0000000000000000000088800003888833 

12524 : 0088888888888800000000000000000000 0000888388880000000000300080838888 

1252B : 8008080080008800000000000000000000 8000080008000008000000000000086830 

12530: 8008800008000000000000000880000000 0000000000000000000000000000888830 

12532: 8000008000000000000000000000000006 0800000000000000008880000000888880 

12534: 8000000000008000000000000000000000 8800000000000000000000000000088000 

1253b : 8008808800808000000000000000330000 8000003000000000000000000000000000 

12540: 8088388003000000000000083000000000 8300000000000000000000000000000088 

1 2S42 : 8888888838888888880000000000000000 8000030000000000000000000000000080 

1 2544 : 8000000000000000000000000800000000 0000000088000000000000000000088888 

1254G : 8000008000000000000000000000000000 0000000000000000000000000000080000 

12550: 0000000000000000000000000888888000 8000000000000000883880000000000000 

12552 : 8000083000000000000000000008000000 OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO 

12554 : 8008883300000000000000000800000000 0000000000000000800000000000000000 

1255B: 8000803080000000000000000000880000 8000000000000000000000000088388830 

125G8: 8000080083830008000000080008000000 0000000000000000000000000080300830 

125S2: 008EG713200014082OO3G00Od377BO3005 0005571320001400200350005377603835 

12554: 004332722000B5402OO420035377B21021 0O43333226O0B54020O42000S377B21021 

1 25ES : 0000008088833380030000000000000000 0000080000000000000000000000088338 

12570: 0043327220085540200420005377521021 0043333220806540200420005377621021 

12572: 0005671320331400200360005377603005 0005671320801400200350006377603005 

12574: 8007776220000000200360005377631000 0O0O00O26OO00O0O20O3S0036377631030 

1257E: 8000000000000000000000000000000000 8000000000000000000000088880008000 

12688: 8848880260142006280362574837828881 8880000000080000000000008888800000 

12582 : 888065662081 8000280257505377643004 080055722001 000020025750G377B43O04 

12684 : 8883207320001 488288368006377603005 0008800000000000000000000000000000 

12606 : 8040000261 000000288880033000321 372 0047151 521 000000670000003000321 371 

12610: 800O2073200014002003B00O5377503005 0000207320001400200350006377603005 

12612: 8000207320001400200350005377603005 0000207320001400200350006377503005 

12614 : 8800207328001400200350006377603005 0000000000000000000000000000000000 

12616: 8000000000000000000000000000000080 O0O6S71 320001400200360006377603005 

12620: 8000406620042001200257506377631000 000040SB2004200120O2575053775310OO 

12622: 8842157228000000202360005377631000 0042327220000000202360005377731000 

12624 : 8868346533812000200000502000060000 8000000272002000200022576377631 000 

12626 : 8806671 328001 400200360006377503005 8880000000000000000000000000000000 
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12539: 0000000000080000088083008000888008 000SB71 320001 4082083S888S377G03005 

12G32: 8000000000008800080888000088888888 8888888000088888888888888888888880 

12B34 : 8088888888808888888888888888000000 0000088000000008888880888888888888 

12B3B: 8888888888888088888888888888888888 8888888000000888888888888888000008 

12B48: 8805S71320e014082883B880S377603085 000SE713288014882883S888S377B03005 

12S42: 00400002B0000000200000033000321002 0880008888388888888000000088888088 

12S44: 0880000000000000000888888888888888 80SO2412200108882883774585814B1815 

12B4S: 88o8S25B288ie0O02e837744O5O14B1021 88B82412288iee882883774585814B1815 

12B58: 08BOS25B28810e002003774405014B1821 08GSB7132881717812237788B377B8248S 

12B52: 0882311B28800O002083S888S377S31888 08BBB7132881717812237788S37770248B 

12B54: 0841717620008003280420005377720377 0000000000000000000000888888888888 

12B5B: 0800000008000000000000000000000000 8020207320013170200037885377583834 

12558: 080214351B0080042013S000S37O402245 002020732001 31 7028883704B377B83834 

125B2: 0002143B1500aO0420135003537040224S 0000207320001488288358885377683885 

12554: 0888888888868000000000000000000000 8858751228818000205377415377651028 

12555: 0058475528818830200377502204021828 8848880250142005200352574037020001 

12570: 0000883388303800300000000030000000 8040000260142005200352574037828831 

12572: 8838000000000000033000000000000000 0000000250008888288358835377531880 

12674: 0888888888880000008000000000000000 0000000008888888888888888888888880 

12575: 0000000000000000000838883030000000 0823878523150540200377506028333385 

12788: 0838388888888838388888888300000000 8383883383388838833883883888338300 

12702: 0000000000000030000000000000000000 0005571320881488238358835377633385 

1 2784 : 0083888888388000000000000000000000 8055571 32001 71 701 22377005377520003 

12705: 000231152000000020035000S377S31000 0865671328817178122377805377720003 

12710: 0041720520080000200420005377720377 0000000000000000000000000888888883 

12712: 0033388000000080000008000000000000 0000000000000000000000088888888880 

1 271 4 : 0030000000000000000000000000000000 0000000000000000000000000000000300 

12715: 0000000008000000000000000000000000 0000000000000008888888888888838888 

1 2728: 0800000000000000000000000000000000 0000000000000000000000000000000008 

12722 : 0888883880000000000000000000000000 0000000000888888888888888883000008 

12724 : 0880888888888800000000000000000000 8883338838383388380888388388383838 

12725: 0383833833838383383888883388833338 8888888888888888880000000000000000 

12730: 0000000000000000888888800000000000 0000000000000000888888888888888888 

1 2732 : 0388333838330000000003000000000008 0000000000000888888888888888888888 

12734: 8800383833888000000000000000000000 0050345233010000200017002077728377 

12736: 0833883333388000000000000000000000 0005571320001400200358885377683885 

12748: 0888883000000000000000000000000888 8835571328881408283358385377683885 

12742: 0880000000000000000000000008000088 0835571328881483288358885377603005 

1 2744 : 0000000000000000000300000000000000 0000000000000088338333388888338338 

12745: 8888888888888883338800000000000000 0005571320881488288368885377683835 

12758: 8838338338833833338338833888888338 8885571328881488283358885377583885 

12752: 0830800000000000000000000000000080 0O05S7132000140020036000S377603005 

12754: 0023411220015558288375745377542184 8383338838883888888888380300000000 

12755: 0000000000000000000000000008000000 0055571320017170122377005377502405 

12750: 0882311628883388288350000377531883 8888888888880000000000000000000000 

12762: 0055571320017170122377005377702405 0041717220000000200420006377720377 

12754: 0000000000030008000000000000000000 0888888338883880888388888888888838 

12765: 0338800088338338888838838838338338 8883388838883388388383888888800000 

12770: 0000000000000000000000000300000000 0041474522002000213375505777602010 

1 2772 : 0000000000000000000000000000000000 0000000000000000000000000000000083 

12774: 0304464220000000200350015377531000 0002055720141060200375546004031000 

12776: 0002055720L41460200376546004231000 0024375220150000200376444052082812 

13000: 0000000000088880000000000000000000 0888888888809088808300000000000000 

1 3002 : 0000000000000000000000000000080800 0000300000000000000000000000000000 

13004 : 0000000000000000000800000000000000 80000S03C3O3O003000O000O0O000O8838 

-13006: 0000000000838300000000000000008080 8000080000000000800000000000000008 

13818: 0883003883838338800000000000000000 0000000000000000800300008880000008 

13312: 0800030000000003880000000000000000 0000000000000000000000000000000003 

1 381 4 : 0800000000000000000000000000000000 0000000000000000000000000000000060 

13015: 0000000000000000000000000000000830 0000000000000003008000000000000000 

1 3020: 000O0C0O0O000000O000O0000000O00OO0 8888838888000000000000000003000000 

13022: 0000000000000000000000000000000000 0000000000000000003000000000000000 

13024: 0000009000000003383883883033888388 8888388888388888883000000000000000 

13026: 0000000000000000000000000000000000 00000000000300C00O0000O000OO0000O0 

13030: 0000000000000000000000000000000000 0000000000000000000000000000000000 

13032: 0000000000000000000000000000000000 8888888888888388800000000000000000 

13034: 0000000000000000000000000000000000 0000000000000000000000000000000000 

1 3035 : 0000000000000000000000000000000030 0000000000000300000000000000000000 

13040: 0000000000000000000000300000000000 0000000000000333383300000000000000 

1 3042 : 8000000000000000000000000000000000 0000000000000000000000000000000000 

13044 : 0000000000000000000000000088000000 0888338883388088833388333000000000 

1 204 6 : 000C3000000000O00000O0O00000OO0000 0000000000000000000000000000000000 

1 3050 : 0009000390000000000000000000000000 0000300000000030000000000000000000 

1 3052 : 0000000000000000008000000000000000 
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Type microcode data. 

8: 444444444A4444444444444444444444 

4er 44444444444444444444444444444444 

1C0: eeeeeAeeeeeeeeeeeeeeeaeeeeeeeeee 

140: eeeeeeeeeeeeeeeddeeeeeeeeeeeeeee 

288: 0BBESEBB68B808004444444444444444 

248: 44444444444444446222248068000000 

300: EBEEEESEE4S444444444444444444444 

340: 4444444444444444SEEE44B4EE444444 

408: 00000000000000004444444444444444 

440: 0000000000000000222200000000000 

500: 00000004040880000000000000000000 

540: 00000000000000000000000000008000 

E00: 00000004000800000000000000000088 

E40: 000000000000000000000 00888888888 

788: 4 4 444444444444444444444444444444 

748: 44444444444444444444544444444444 

1800: 00050000000000004444444444444444 

1840: 55555555555555550888888888888888 

1180: 00000000000000004444444444444444 

1140: 00000000000000000080088000000000 

1200: 45444444444444444444444444444444 

1240: 44444444444444444444444444444444 

1300: 54444444444444444444444444444444 

1340: 44444444444444444444444444444444 

1400: 000000E000000000000000000000O80 

1440: 000000 0000000000222200000000000 

1588: 444454 4 4444444444444444444444444 

1548: 44444444444444444444444444444444 

1588: 88800E80080000085555555555555555 

1E48: 80000000000000000222200000000888 

1780: 00 8 88000000000000000000000008888 

1740: 00000000000000000002004400000000 

2008: 86887800000000000000000080000000 

2040: 00000000000000000222288888888888 

2180: 08888888884888000000000000000000 

2148: 00000000000000000000000000000880 

2208: 444444 4 4404000004444444444444444 

2240: 44444444444444444222240040000000 

2380: ESEEEEEEE0E000004444444444444444 

2348: 44444444444444446E222400E0000000 

2408: 44444444484800004444444444444444 

2440: 44444444444444444422240040000000 

2500: 884888000000000000000 0000000800 

2540: 888888000000 0000000000000000000 

2688: 0440000000000 000000000000 008000 

2540: 88880000000000000000000000000880 

2700: 544 4 4444404000004444444444444444 

2740: 44444444444444444222240040000000 

3888: 44444444404800004444444444444444 

3040: 44444444444444444442444444000000 

3108: 888888888880000000000000000000 8 

3140: 4444444444444444000000000000 000 

3208: 44444444444444445555555555555555 

3248: 55555555555555554444444444444444 

3388: 44444445444444444444444444444444 

3348: 44444444444444444444444444444444 

3488: 45544444444444444444444444444444 

3448: 4 4 444444444444444444444444444444 

3588: 444544444444444455555555555555 55 

3-348: 5555 5555555555554444444444444444 

3680: 44444444444444444444444444444444 

3B48: 5555555555 5 555554444444444444444 

3708: 44454444444444444444444444444444 

3748: 4 4 4 4 4 4 4 4 444444444444444444444444 

4088: 4 4 4 5 4 4 4 4 4 4 4444 4 44 4 444 44444444444 

4040: 5555 5 555555555554444444444444444 

4100: 00004580080000000800 00000088088 

4148: 80000000800000000000000000000000 

4200: 44444444404000004444444444444444 

4240: 44444444444444444442240040000000 

4300: 00004400000000008880888888800000 

4340: 8 800000000000000000000000008888 

4483: 8588440000000000000000000000 0000 

4440: 00000000000000000000000000000000 
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ASea: 44444544444444444444444444444444 

4540: 44444444444444444444444444 4 44444 

4B03: 44444544444444445555555555555555 

4B40r 44444444444444444444444444444444 

4700: 44444444444444445555555555555555 

4740: 44444444444444444444444444444444 

5000: 00040080000000005555555555555555 

5040: 44444444444444440000000000000000 

5100: 00040800000000004444444444444444 

5143: 44444444444444440080000000000800 

5Z00: 44444454444444444444444444444444 

5240: 44444444444444444444444444444444 

5300: 000 0000000000000000000000888888 

5340: 88000000000000004080000 8 48888000 

5400: 00000600000000000800000000000000 

5440: 00000000000000000222200000000000 

5500: OGSSGB7BBO5O00004444444444444444 

5540: 4444444444444444B222240OB000000O 

5S00: 05004000000000000000000000000800 

5S40: 00000000000000000000000000000000 

5700: 44444444445444444444444444444444 

5740: 44444444444444444444444444444444 

5080: 44444444544444444444444444444444 

5040: 44444444444444444444444444444444 

B100: 44544444444444444444444444444444 

B140: 444444444444444444444444 4 4444444 

MICROCODE COMPILER 
3600 Microcode 1 Introduction 

L Introduction 

This document is both to explain the underlying concepts of the microcode compiler and to 
serve as reference documentation on how to write microcode. The first part of this document 
explains the philosophy of the microcode compiler and is largely independent of the hardware. The 
second part describes the microcode operations available; in some sense this constitutes 
documentation of the hardware, however the reader is assumed to be familiar with the hardware. ^L. 
least at the block-diagram level. 

LI Structure of the Compiler 

The 3600 microcode compiler consists of a front end, a checker, two back ends, and a linker. 
The input to the compiler is written in a microcode source language, which has Lisp-like syntax 
but the semantics of microcode. This language is considerably higher level than the actual 
microcode executed by the machine, but is in no sense a high-level or general-purpose language; it 
is impossible to program in it without general knowledge of the microcode architecture of the 
machine. The purpose of the microcode source language is to provide a more comfortable syntax, 
to take care of some elementary bookkeeping, and to provide extensive error checking so that the 
microprogranmier's knowledge of the microcode architecture need not be perfect for her to program 
effectively. 

The front end converts the microcode source langxxagc into a primitive form. This primitive 
form is horizontal microcode expressed in symboUc form, rather than as a bit string; it is a Ust of 
microinstructions, where each microinstruction is a list of microinstruction fields and values for 
those fields. To look at it in another way, each primitive symbolic microinstruction is a list of 
machine operations to be performed in parallel, and these machine operations are the primitive ones 
actually implemented by the hardware, rather than any higher-level abstractions that the 
programmer would use. An effort was made to keep the symbohc microinstructions close to the 
actual microinstructions executed by the machine, so that the "smarts" of the compiler would be in 
the front end, and the back end would simply be a trivial transformation from symbolic 
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microinstructions to their actual bit encodings. However, there are some decisions that are difficult 
to make in the front end, because they require global knowledge. These decisions are made in the 
back .end, which means that the symbolic microinstruction is not identical to the real 
microinstruction. For example, choices between two different ways of encoding the same function 
arc made in the back end. A few additional minor "unrealities" in the symbolic microinstruction 
are there to simplify the simulator. 

The front end is essentially a macro expander. The microcode written by the user consists of 

nested expressions in the style of Lisp; the car of an expression is the name of a macro that 

defines the operation to be performed. The microcode source language will be discussed in detail 
later. 

The checker checks the primitive symbolic microcode output by the front end for legality. It 
checks for unknown symbolic field names, for unknown symbolic field values, for dependencies 
between fields. The symbolic microcode is not perfectly horizontal: there are dependencies between 
fields. To take some examples, reading the output of a memory requires specifying an address for 
that memory, many operations are "modulated" by the magic number field, and some combinations 
of fields are not allowed by the hardware. The main purpose of the checker is to detect bugs in 
the front end (the macros are many in number and possibly user-written). This checker is partly 
table-driven and partly ad-hoc; it was written in whatever way seemed most convenient at the time. 
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The front end also does tome checking; whenever two things are done in parallel it checks that 
they are consistent. Part of this check is simply to assure that the same symbolic microinstruction 
field is not given two different values, and part of the check involves machine-dependent knowledge 
of how to encode parallel operations. Of course the front end also checks for trivial syntactic 
errors such as using an undefined macro, using a macro with the wrong number of arguments, etc. 
Most error messages seen by the user will be from the front end. 

One back end translates symbolic microcode into Lisp functions to simulate its action, miming 
within a simulator environment which runs in both Maclisp and the Lisp Machine. The simulator 
allows microcode to be debugged with the tame editing and debugging tools as Lisp programs. The 
simulator is deficient in certain details, mostly having to do with memory and I/O, but simulates 
the microcode that executes the compiled Lisp instruction set very well. 

The other back end translates into the actual microcode executed by the machine. This 
consists of translating symbolic microinstruction fields into the appropriate bit strings, packing the 
fields together, and making certain decisions when there are overlapping fields in the hardware 
and /or multiple ways of encoding a symbolic operation. 

The linker combines separately-compiled microcode modules into an almost-complete image of 
the hardware memories. Constants are assigned to addresses. Microinstructions are also assigned to 
addresses; this is a complex process because there are several relationships between the addresses of 
multiple microinstructions: the hardware microinstruction has only a single successor address field, 
whereas in general two successors are required (e.g. the address of a subroutine and the address it 
should return to, or the address of the normal successor and the address of a trap handler which 
receives control in exceptional cases); the microcode to execute a macroinstruction must be at a 
certain address determined by the Instruction Fetch Unit; the skip and dispatch features involve 
tables of microinstructions located in a block of addresses. The linker makes multiple copies of a 
microinstruction when necessary to satisfy these constraints, and merges together microinstructions 
that come from different places in the source code but turn out to execute the same machine 
operations. The linker generates a symbol table for the microcode debugger, and a variety of 
report files showing how addresses were assigned. 
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L2 Level of Sophistication 

The 3600 microcode compiler is primarily analytic rather than synthetic. In other words, it 
does little planning or scheduling of the use of hardware resources, and its input is not a general- 
purpose programming language, but one whose primitives correspond closely to the hardware. It 
takes a program written by a human and analyzes it to make sure that it will work (the human 
has not out-smarted himself). 

The compiler does no scheduling (arrangement of machine operations in time). The 
programmer must explicitly say which operations arc to be done in parallel and which operations 
are to be done sequentially. The compiler will then say whether or not this "schedule" will work, 
but it has no idea whether or not this "schedule" is the most optimal one. The compiler knows all 
the hardware reasons why two operations cannot be done in parallel (e.g. they might require two 
different data words to be present on a single data path at the same time, or they might require a 
single microinstruction field to contain two different values). It would be much too difficult (for 
this project) to write a program which could schedule the performance-critical microcode as well as 
human ingenuity can. 

3600 Microcode 3 Macros and Micros 



Things are somewhat simplified because the hardware does some very low-level scheduling. One 
example of this is that all read /write memories contain pass-around paths so that a value may be 
wrinen into the memory and read back correctly in the immediately-following microinstruction 
(even if it has not yet really been stored into the memory). This means that neither the compiler 
nor the programmer needs to worry about scheduling issues across multiple microinstructions, but 
only within a single microinstruction. 

The microcode compiler has about the same lack of intelligence in the space domain as in the 
time domain. The programmer generally has to have a good idea of which data paths in the 
machine his microcode is using. The programmer must choose explicitly whether variables and 
constants reside in the A memory or the B memory (the machine can access one A-memory 
location and one B-memory location simultaneously, but not two locations in the same memory,) 
The compiler does not take a high-level description of what is to be done and map it onto the 
data paths. However, the situation is not hopeless. The compiler does make the simplest data-path 
planning decisions on its own; for instance it will take advantage of the symmetries of the ALU. 
This will be discussed in detail later. In addition, if the programmer mistakenly tries to use the 
data paths in an impossible way, the compiler will detect this. 

L3 Macros and Micros 

The source file for a microcode module is a file full of Lisp forms, much like the source file 
for a Lisp program. There are certain defining forms^ which are Lisp forms (macros, actually) 
that define microcode subroutines or other microcode-related things. Inside of a Lisp form that 
defines a microcode subroutine appears some actual microcode (in the source language form). This 
microcode could be written directly in the primitive, symbolic microinstruction form, however it is 
invariably written in a higher-level form, in terms of micros. Micros are the macros expanded by 
the front end of the microcode compiler. They are called micros to distinguish them from normal 
Lisp macros. 

The syntax of the microcode source language is as follows. A valid form (or expression) is one 
of 

a primitive A primitive is a list whose car is the name of one of the primitive 

operations defined in the next chapter, and whose cdr is the appropriate 
arguments to that operation. 
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the invocation of a micro 

This is a list whose car is the name of a micro and whose cdr is 
interpreted in a way defined by that micro. 

a symbol The symbol must be defined as an atomic micro. Most atomic micros are 

used the way variables are used in Lisp. The phrase atomic micro is 
usually abbreviated to atomicro. 

Note that the Lisp concept of evaluation does not apply to the microcode language, even 
though it looks much like Lisp. A microcode form is processed by expanding it into another form, 
if it is the invocation of a micro or an atomic micro, or by converting it into hardware microcode, 
if it is a primitive. 

The compiler comes with a large number of micros pre-defined. These micros embody 
knowledge about the hardware architecture (how to get the machine to do things) and about the 
software architecture implemented by the microcode (conventions about storage layout, names of 
fields in data structures, etc.) The predefined micros include the usual set of control-structure 

operations, some additional control operations corresponding to the hardware, and data operations 
corresponding to all the data manipulations the hardware is able to perform. 

There is a defining form (defmlcro, a Lisp macro) which can be used to define new micros. 
Its body is a Lisp program which sees the invocation of the micro and computes a new microcode 
form to serve as its expansion. The front end works by calling the Lisp program associated with 
each micro it sees, until everything has been expanded into primitives. There are other defining 
forms for atomic micros. 

L4 



L5 Running the Compiler 

On a Lisp machine, load the file F:>LMach>Ucode>SYSDCL.LISP then do (make-system 
*micro). This will load the compiler, the simulator, and the microcode. The source files for 
cvcrjthing are on the F:>LMach>Ucode> directory. 

The micro system consists of two components: microcompller, the compiler and simulator; 
and microcode, the microcode proper. To compile microcode, just use the Lisp compiler, or 
make-system. 

The variable •enable-ul* enables translation of microcode into Lisp code for the simulator. 
It is nil by default. The variable •enable-uh* enables translation of microcode into hardware 
instructions. It is t by default. 

When using the simulator, microcode is compiled into Lisp functions, using the normal Lisp 
compiler, and these Lisp functions are run with the aid of support functions in the 
microcompller system. When using the real hardware, microcode is compiled into linkable 
microcode (in normal QFASL files). These files are loaded and the microcode is then processed by 
the following functions: 

link-the-microcode 

Build a microcode memory image out of all of the microcode that has been loaded. 
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linker-summary-report 

Print a summary of the results of the most recent link-the-microcode. This consists 
_ mainly of how many locations were used. 

3600 Microcode 5 Running the Compiler 



iinker-detailed-report 

Print a detailed listing of the results of the most recent iink-the-microcode. This 
includes complete symbol tables and maps of control memory. 

tiie-linker-report pathname 

Write a file named pathname containing the output from linker-summary-report and 
linker-detaileckreport. 

write-the-microcode ioptional name version 

Write the results of the most recent Nnk-the-microcode into a set of microcode binary 
files {see below). The files are written to 

F :>LMach>Ucode>nflme. type, version 
name defaults to NORMAL; type is different for each output file; version defaults to the 
major version number of the microcode system, which is incremented each time it is 
compiled. 

version also appears as the contents of the A-memory location named 
%microcode-version-number. 

compile-the-microcode 

Link the microcode and then write it. Note that (at least currently) 
compite-the^microcode does not actually compile the microcode source files; use 
make-system for that. 

The :toad-ucode command in the I Console program calls compile-the-microcode if 
necessary, and then loads the newest microcode binary files. 

L5.1 Microcode Binary Files 

The microcode is stored in three files, with types MIC, SYM, and ERR. 

MIC This file contains the load image for the microcode memories in the machine. It is a 
sequence of 16-bit bytes, as follows: 

First, the microcode version number. 

Following that, a sequence of load blocks. Each block starts with a memory number, a 
starting address, a number of entries, and the number of 16-bit bytes per entry. The 
entries (data words to be loaded into consecutive addresses) follow. Each data word 
occupies an integral number of 16-bit bytes, e.g. 3 bytes for 36-bit words. 

The memory numbers are: 

1 - type map 

2 - A memory 

3 - B memory 

4 - C memory 

SYM This file contains the symbol table, as a series of Lisp lists, each having an identifying 
symbol in its car. These symbols are: 
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version 



The microcode version number is the cadr of the list. 



ERR 



•-memory The rest of the list is an a-Iist associating symbols with A-memory 
addresses. 

b-memory The rest of the list is an a-Iist associating symbols with B-memory 
addresses. 

c-memory The rest of the list is an a-list associating microinstruction names with lists 
of control-memory addresses. A microinstruction can be stored in more 
than location when address constraints so dictate. A microinstruction name 
is either a sjTnbol (specified with defucode or deflnst) or a list, which is 
one path from a symbol-named microinstruction- to here. When there can 
be multiple paths to a microinstruction (because identical microinstructions 
from different sources were merged by the linker), only one path is 
remembered. 

This file contains the error table, which \s read by the Lisp system during loading. It tells 
the error handler how to interpret error traps from the microcode. The format is similar 
to the SYM file. Valid cars of lists are: 



version 
error-table 
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The microcode version number is the cadr of the list. 

The rest of the list is an a-list associating control-memory locations to error 
codes, specified by the signal-error micro, for example. 

7 Primitives 



2, Primitives 

A micro expands either into another micro expression or into one of four primitives. These 
primitives are statements (a single microcode operation), sequences (a list of statements to be 
performed sequentially), data (representing the location of data in the machine), and predicate (a 
special kind of data used as a conditional test). 

The output of the micro expansion phase consists of pieces of microcode (something like 
leparate Lisp functions). Each piece of microcode is either a statement or a sequence. Along with 
the microcode itself is declarative information such as its name or the fact that its purpose is to 
execute a certain macrocode instruction. 

We will discuss the primitives first, even though the microprogrammer normally never uses the 
primitives directly, but always programs in terms of the predefined micros and new micros that she 
writes. 



21 Statements 

A statement is a single microinstruction. The symbolic form of a statement is a list 
(microinstruction field value field value. . . ) 
The fields and values are a symbolic representation of the machine microinstruction. The actual 
microinstruction is simplified somewhat, and made more fully horizontal, to simplify the macros. 



For example, the microinstruction 
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(microinstruction abus amem 

amem-read-addr (stack-pointer 0) 

xbus abus 

alu X+1 

write-amem obus 

amem-write-addr (stack-pointer 0) 

write-bmem obus 

bmem-write-addr 4) 
specifies that the A-memory location addressed by the stack pointer, with an offset of zero (i.e. the 
top of the stack), is to be incremented by one and stored back into itself, and also into location 4 
in the B memory. Data is to be routed from A memory into the ALU via the Abus and the- 
Xbus. 

Sequences 8 3600 Microcode 



2J Sequences 

A sequence is an ordered list of microinstructions to be performed one at a time. The symbolic 
form of a sequence is a list 

(microsequence statement statement,,,) 

12 Data 

A datum represents a word of bits on some data path in the machine. The exact location in 
the machine is specified, along with a microinstruction that arranges for the desired data to appear 
at that place when it is executed. This primitive serves the place of expressions in conventional 
languages. Thus, a micro that represents an expression with a value expands into a datum, while a 
micro that represents an imperative command with no value expands into a statement or a 
sequence. 

The symbolic representation of a datum is a list 
(microdata place statement) 

The machine does not execute data; it only executes statements. In other words, the 
microcode language is a statement language, not an applicative expression language, and the fiow of 
data must be programmed explicitly, with the programmer naming temporary storage locations 
where they are required. Thus data only appear as intermediate operations during the microcode 
expansion process. When a datum is used as an argument to a micro (for instance, one that takes 
two data and adds them together in the ALU), the datum's place tells the micro how to generate 
data-routing microcode, and the datum's statement is merged into the generated microinstruction 
and executed in parallel. 

A datum may also be used as the first argument to the assign micro, in which case the 
datum designates a place into which bits will be stored, rather than a place from which bits will 
be retrieved. This generality increases the symmetry of the source language. 

It is also allowed to have a sequence (rather than a single microinstruction) inside a datum. 
This is useful if it takes several sequential machine operations to make the desired datum accessible. 
However, use of this feature \& likely to cause non-intuitive behavior, since something that 
syntactically appears to be z statement, but contains such a datum, will really be a sequence. In 
applicative constructs involving data, the order in which operations are written usually is 
determined by esthetics rather than by the order necessary for things to work. Normally an 
expression is executed in a single microinstruction (i.e. evaluated in parallel), and so the order of 
operations makes no difference. But if a datum in the expression has a sequence buried inside it, 
the expression will necessarily be executed in multiple microinstructions, and it might not be 
obvious which things were done in parallel. 
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2.4 Predicates 

A predicate represents a true-or-fabe condition that can be tested. In the 3600 ail such 
conditions appear on a single condition multiplexor, whose output may be used to divert the flow 
of control with either a skip or a trap. 

The symbolic representation of a predicate is much like a datum; a list 
(microconditlon condition-name sense statement) 
condition-name is the name of a testable condition in the hardware, sense is the symbol true or 
the symbol false, false indicates that the negation of the hardware condition is represented. 
Predicates may only be used as arguments to condition-testing micros (such as If, not, or trap-if). 

Combining Forms 10 3600 Microcode 



3. Combining Forms 

There are two combining forms, which can be used to combine several microcode expressions 
into one. The expressions being combined will usually be statements (or forms that expand into 
statements), but it also makes sense for them to be sequences. A datum or a condition may be 
combined with statements or sequences, which makes a new datum- or condition whose 
microinstruction part is combined. 

sequential forml form! ••. Micro 

The argument forms are to be executed sequentially. To make life easier for micros, if 
any of the forms is nil it is ignored. 

parallel forml form2 ... Micro 

The argument forms are to be executed simultaneously, in parallel. This form will expand 
into a single microinstruction, unless one of the forms is a sequence. In that case, the 
forms written before the sequence will be done in parallel with the first microinstruction in 
the sequence, and the forms written after the sequence will be done in parallel with the 
last microinstruction in the sequence. Thus the order of arguments to parallel does 
matter. When microcode is written with this in mind, it will usually be more readable 
anyway — the parallel clauses will "flow" naturally. 

For example, 

(parallel forml 
forml 

(sequential formSa form3b formSc) 
form4 ) 
is equivalent to 

(sequential (parallel forml 

forml 
formSa) 
form 3 b 

(parallel formic 
form4)) 

To make life easier for micros, if any of the forms is nil it is ignored. 

Microcode is usually written in such a way that correct execution does not depend on which 
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combining form is chosen; this only affects speed. (Of course, not everything can be done 
instantaneously, and so correct execution may be impossible with paraiiei; the compiler detects 
this.) 



The control-structure micros, such as conditionals and dispatches, are something like combining 
forms in that their arguments are microinstructions. They will be described below. 
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tor-effect datum Micro 

Convert a datum into a statement. This is useful when the datum has side-effects in its 
microinstruction part (typically popping the stack), but the value is not needed. 

Defining Forms 12 3600 Microcode 



4, Defining Forms 

defucode name body.,. 

Define a microcode routine which is named name. The body forms are implicitly combined 
with sequential. The microcode routine may be reached by a jump, a subroutine call, or 
a trap, using name. 

defucode-at-loc name loc body... 

This is like defucode, but requires that the microcode be stored at a particular address. 
loc is either a number or a list of numbers. The first microinstruction of the body will be 
stored at that location, or at all of those locations, defucode-at-loc is used to set up 
things like trap handlers whose addresses are known by the hardware. 

definst name attributes body... 

Define the microcode routine to execute a particular macroinstruction. name is the name of 
the macroinstruction. attributes is either a list whose first element is the format of the 
macroinstruction and whose remaining elements are its other attributes, or a symbol which 
is the format, in the common case where there are no other attributes. The format and 
attributes are checked against the Opdef file; that is the file which tells the compiler what 
the macroinstrucrion set is. Formats and attributes are further described below (page 14). 

definst is essentially defucode-at-loc, except the location is automatically computed by 
looking up name in the opcode table. You must explicitly put a (next-instruction) at the 
end of the microcode if it is needed. 

definsti name attributes body... 

A version of definst for macroinstructions that can be executed in a single machine cycle. 
The body forms are combined with parallel rather than sequential, and 
(next-instruction) is automatically appended to the body. 
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defareg-at-loc name location &optional initial-value simulatoHnitial-value 

Define name to be the word in A-memory at address location. If initial-value is supplied, 
_ it is a Lisp expression to compute a number to be stored there, simulator-initial-value 
defaults to initial- value but allows a different value to be stored when using the simulator 
(usually it is conceptually the same value but is computed in a different way.) 

defareg name &optional initial-value simulator-initial-value 

Like defareg-at-loc but the system chooses the location. If name has been previously 
defined at a specific location, then the same location is used; this is useful because the 
Sysdcf file defines a number of A-memory variables at specific locations which are used for 
communication between microcode and Lisp code. If name has not been previously defined 
at a specific location, a location is assigned from a free pool set up by 
reserve-scratchpad-memory. 

3600 Microcode 13 Defining Forms 



defbreg-at-ioc name hcaiian ^optional initial-value simulator-initial-value 
Like detareg-at-loc but for B memory. 

defbreg name location ^optional initial-value simulator-initial-value 
Like defareg but for B memory. 

reserve-scratchpad-memory first-a last-a &optional first-b last-b 

Establish an area of A-naemory, and optionally of B-memory, in which variables are to be 
allocated by defareg and defbreg. A reserve-scratchpad-memory form should be 
put at the front of each microcode file. This kludge is necessary because locations have to 
be assigned at compile time (rather than when the microcode is linked) for the sake of the 
simulator. 

defmicro name orgs body.„ 

This is much like the Lisp def macro, but defines a micro. The last body form should 
evaluate to a microcode form (a micro invocation or a primitive.) Note well, the body is 
not microcode; it is Lisp code that constructs microcode. 

orgs may include the keywords &optional, irest, &body, and &aux. The def macro 
feature that orgs may include more general patterns, not just variables, is not supported 
currently. Optional arguments may have default values (which are Lisp forms to be 
evaluated, if the argument was not supplied, to produce a piece of microcode to use as the 
argument). 

defatomicro name expansion 

Define name to expand, when it appears by itself as a microcode expression, into expansion. 
Note that expansion is a microcode expression, not a Lisp form to be evaluated to produce 
a microcode expression. 

defatomic-byte-field name byte-specifier register 

Define name to be an atomicro which expands into a datum representing a byte of the 
datum register. The byte is specified by byte-specifier^ which is either a symbol, or a list 
of n-bits and bits-over, A symbol must be the name of a byte defined in the Sysdef file as 
part of the machine architecture. n-bi(s is the width of the byte in bits, bits-over is the 
position of the byte in bits from the right-hand end of the word (in other words it is the 
bit number of the least-significant bit in the byte). 

def-byte-field name byte-specifier var 

Define name to be a micro which takes an operand as its argument and expands into a 
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datum rtpresenting a b}te of that operand, byte-specifier is the same as in 
defatomic-byte-tield. var \s the dummy variable to be bound to the op>erand. 

associate-dispatch-cues field-name enumerated-type-name 

Declare that the byte field named field-name contains values of an enumerated type defined 
by (defenumerated enumerated-type-name ...) in the Sysdef file. A dispatch (see 
dispatch-after-next, page 18) on the field will allow the symbolic names of the 
enumerated type values to be used as dispatch cues. 
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define-enumerated-vaiue-constants enumerated-type-name 

Declare an enumerated type defined by (defenumerated enumerated-type-name ...) in the 
Sysdef file. Each symbolic value of this type is defined to be an stomicro which expands 
into a B-memory constant containing the numeric code for that vdue. This allows symbolic 
values to be deposited into fields in data structures. 

define-storage-word-off set-constants defstorage-rype-name 

Make available to the microcode the symbolic names for the words in a system data 
structure defined in the Sysdef file. Each word offset is defined to be an atomicro which 
expands into a B-memor>' constant containing the numeric value. 



4J Macroinstruction Attributes 

The following are the macroinstruction formats currently allowed: 

unsigned-immediate-operand 

The instruction includes an 8-bit immediate constant, which is unsigned. The atomicro to 
pick up the operand is macro-unsigned-immediate. 

signed-immediate-operand 

The instruction includes an 8-bit immediate constant, which is a 2*s-complement signed 
number. The atomicro to pick up the operand is macro-signed-immedlate. 

10-bit-immediate-cperand 

The instruction includes a 10-bit immediate constant; the extra two bits are taken out of 
the opcode. This format is used for certain byte-manipulation instructions only. 

address-operand 

The instruction addresses the current stack frame; one bit selects between a positive 7-bit 
displacement from frame-pointer or a negative-or-zero 7-bit displacement from stack-pointer. 
The atomicro to pick up the operand is address-operand. 

no-operand 

The instruction has no direct operand (usually some operands will be passed on the stack). 

quick-external-call 

The instruction includes an 8-bit unsigned immediate constant to be interpreted as an index 
in the system-wide table of quick-external functions. 

constant-operand 

The instruction includes an 8-bit unsigned immediate constant which is a negative index 
into the constants table of the current function. 
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indirect-operand 

The instruction includes an 8-bit unsigned immediate constant which is a negative index 
into the constants table of the current function. The addressed word contains a locative 
pointer to the value cell or function cell whose contents are the operand. 
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lexical^-cperand 

The instruction includes an 8-bit unsigned immediate constant whose interpretation is not 
yet fully defined. 

microcode-operand 

The instruction includes an 8-bit unsigned immediate constant which is an index into the 
system-wide table of constants and microcode-communication variables. 

unsigned^pc-relative 

The instruction includes an 8-bit unsigned immediate constant which is a PC-offset (see the 
pc^add micro, page 41) to be used for branching. 

8igned-pc*relative 

The instruction includes an 8-bit signed immediate constant which is a PC-offset (see the 
pc*add micro, page 41) to be used for branching. 

constant-pc-relative 

Identical to constant-operand except that the addressed constant is to be used as an 
offset from the PC for branching. (See the pc-add micro, page 41.) 

After the format in a definst, any number of attributes may be specified. The following are 
the currently-defined attributes (more will undoubtedly be added in the future): 

needs-stack 

The top-of-stack register must be valid when this instruction is entered. 

smashes^tack 

This instruction leaves the top-of-stack register invalid. 

branch-predict 

The IFU should assume that this instruction branches and take the next instruction from 
the branch target. The format must be signed-pc-relative. 

stop-ifu 

The IFU should cease referencing memory until told what to do next. 

(function name n-arguments n-values) 

This instruction implements the Lisp function named name when called with n-arguments 
arguments, n-values values are returned on the stack, n-values may be omitted and 
defaults to 1; is commonly specified for functions mainly used for their side-effects. The 
arguments are passed on the stack except that if the format is not no-operand then the 
last argument is the operand. Multiple instructions may have function attributes for the 
same function; the compiler will choose the appropriate instruction in context. 

(operand type-of -operandi 

Additional information about the operand, used by the disassembler to print it in a nicer 
format than just a number. The current list of operand types is: 

data-type An immediate data type code, as used by %make-pointer. 

byte-pointer An immediate byte pointer, as used by Idb. 
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argument-number 

The sequence number of an argument; is the first argument. This is 
used by argument-taking instructions. 

instance-variable 

A reference to an instance variable (mapped or unmapped). 

3600 Microcode 17 Flow of Control 

5. Flow of Control 

Several of these micros use the concept of normal successor. The normal successor of a 
microinstruction is that microinstruction which is executed inmiediately afterwards, in the absence 
of any fiow-of-control micros. Only microinstructions embedded in sequences have normal successors 
(note that defucode implicitly wraps sequential around its body, thus all microinstructions in 
the body except the last have a normal successor). 

5J Jumps and Subroutines 

jump ucode Micro 

Take the next microinstruction from the routine named ucode. 

call ucode Micro 

Take the next microinstruction from the routine named ucode and save as the subroutine 
return address the normal successor of the current microinstruction. 

call-and-dJspatch-upon-return ucode Micro 

A combination of call and take-dispatch (see page 19). The subroutine's return address 
is made to be the dispatch set up in the previous microinstruction. In the hardware this is 
the same as call; a separate name is provided to make the microprogram easier to read, 
and for the benefit of the simulator. 

call-and-return-to ucode return-to Micro 

Take the next microinstruction from the routine named ucode^ and save return-to as the 
subroutine return address. 

return Micro 

Take the next microinstruction from the saved subroutine return address, and pop the 
subroutine return stack. Each task has 16 stack locations. 

next-instruction Micro 

Take the next microinstruction from the address supplied by the Instruction Fetch Unit. 
The current microinstruction is the last to be executed on behalf of the current 
macroinstruction; the next microinstruction will either start the next macroinstruction, 
handle a trap or sequence break, or idle wzixing for the IFU to become ready. 

In the hardware next-Instruction and return are identical operations; when the 
outermost subroutine in the emulator task returns, the hardware does a next-instruction 
operation. The two names for this operation are to make the microprogram more readable. 
It is entirely legal to call a macroinstruction-execution microroutine as a subroutine. 
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5.2 Conditionals 

if predicate true false Micro 

Test the predicate) if it is true, take the next microinstruction from /n/e, otherwise take 

the next microinstruction from fahe. The available predicate micros are described in 
section 6.3, page 27. 

Each clause {true or false) may be a microcode expression, the form (goto tag) which 
means the microcode routine named tag^ or the form (drop-through) which means the 
normal successor of the current microinstruction. If a clause is a microcode expression, its 
normal successor is the It's normal successor, i.e. it rejoins the normal flow of control. 

Using Mump tag) as a clause is equivalent to (goto tag) except that it is one cycle slower, 
because it generates a microinstruction that does nothing except a jump, as opposed to 
goto, which arranges to transfer control directly to the named routine (in some cases this 
may involve making a copy of that routine; the linker takes care of this). 

Compare If with trap-if (page 19). 

call-select condition true- subroutine false-subroutine Micro 

A combination of \i and cad. The condition is tested and in the next cycle control passes 
to true-subroudne if it was true or false-subroutine if it was false. In either case a return 
address is pushed on the microcode subroutine stack. 

5J Dispatching 

dispatch-after-next field clauses,.. Micro 

Select one of the clauses according to the value of field. The current microinstruction's 
immediate successor may then use the take-dispatch micro to transfer control to the 
selected clause. Note that dispatch-after-next and If may be used simultaneously, 
which provides a way to make the taking of the dispatch optional. 

The car of a clause is the condition under which that clause will be selected. This can be 
a list of symbolic or numeric values for field, or the special symbol otherwise. The cdr 
of a clause is a list of microcode expressions; sequentially is implicitly wrapped around 
them. As a special case, (goto tag) is allowed in dispatch clauses; it works the same way 
as in If. (drop-through) is not allowed; its meaning is unclear because of the "after 
next** nature of dispatching. 

Symbolic field values that appear in the car of a dispatch clause are defined with the 
associate-dispatch-cues defining form (see page 13). 

field selects a field of up to 4 bits in the data path, thus dispatches may select among up 
to 16 possibilities. Normally the byte-extraction hardware is used to select the field (see 
the Idb micro, page 30). field may also be an invocation of the cdr-code micro, 
allowing a 4-way dispatch on the cdr code of an Abus source. 
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Signah-error error-code,.. Micro 

Abort the current macroinstruction and exit to the error handler, passing the symbolic 
error message specified by the error-code arguments. 

signal-error-no-restore-stack error-code... Micro 

Identical to signal-error except that the stack-pointer remains at its current setting. 
signal-error would restore it to its value at the start of the macroinstruction. 

error-lf condition error-code... Micro 

If condition is true, trap to the error handler, passing the symbolic error message specified 
by the error-code arguments. This is equivalent to 

(trap- if condition (signal-error error-code. . .)) 
but saves a control-memory location. 

srror-no-restore-stack condition error-code... Micro 

Identical to error-lf except that the stack-pointer remains at its current setting, error-if 
would restore it to its value at the start of the macroinstruction. 

Check-arg-type location datum typel type2... Micro 

Trap if the data type of datum is not one of the types listed, datum must be an Abus 
source. No trap handler is specified; the trap always goes to a fixed location (trap in the 
type map is used). This micro is typically used by instructions and subroutines to check 
the types of their arguments. The trap-O microcode normally passes control to the Lisp 
error handler. 

location is a symbolic specification of where datum came from. It is passed along in the 
error code and used by the error handler to format the error message, to locate the 
offending datum, and to replace it with a new value if the instruction is retried. In many 
cases an error is detected by a subroutine used in common by several instructions which 
get their arguments from different places. The location provides a symbolic specification 
which the error handler uses, in combination with the panicular instruction that was being 
executed, to find the physical location of datum, 

location should be one of the following: 

a number One of the arguments to the function implemented by the instruction; 

specifies the first argument. 

nil One of the arguments to the function implemented by the instruction, but 

it is not specified which one. The error handler will test the arguments 
and select the first one whose data type docs not match the types specified. 

*^''ay The array argument to an array-manipulating instruction. Whether this is 

the first or second argument depends on the instruction. 

subscript One (or more) of the subscript arguments to an array-manipulating 
instruction. 

top>H3f-stack The top value on the stack (i.e. the last argument). This is used by the 
funcall instructions, for example. 

rest-arg The rest-argument being passed by a lexpr-funcall instruction. 

return-pc The current frame's return PC (PC of its caller). 
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telf-mapping-table 

The instance-variable mapping table in the current frame. This is an 
implicit argument to tht instance-variable accessing instructions. 

instance The instance argument to an instance-variable accessing instruction. This 

can be either an explicit argument or an implicit one (self in the current 
frame), depending on the particular instruction. 

instance^ize 
instance-binding 
instance-hash-table 
instance-hash-table-ent ry 

Various attributes of the instance argument (see instance just above). 

any Any one of the arguments to a function that takes several arguments all of 

the same type. 



checic-data-type datum typel typel... Micro 

Trap if the data type of datum is not one of the types listed, datum must be an Abus 
source. No trap handler is specified; the trap always goes to a fixed location (trap in the 
type map is used), check-data-type is the same as checlc-arg-type with a location of 
nil. 

data-type-trap datum trap-name typel type2... Micro 

Trap if the data type of datum is not one of the types listed, datum must be an Abus 
source. This is the same as checic-data-type except that you may specify which of the 
type map traps to use (trap-0, trap-1, trap-2, or trap-3) and no automatic error-table entry 
is made. 

The following micros are essentially special cases of trap-It usually used in generic arithmetic 
macroinstructions. 

checi(-fixnum-2args a-opnd i^opnd clauses... Micro 

Q-opnd is an Abus operand and b-opnd is a Bbus operand. The data types of these two 
operands are checked. If both are fixnums, execution proceeds normally. If either is not a 
number, a uap-0 to the error handler occurs. If both are numbers, but they are not both 
fixnums, one of the clauses is selected as the trap handler. The clauscr. look like dispatch 
clauses. If only an otherwise clause is present, no dispatch occurs (i.e. memory is not 
wasted for a dispatch block of 16 identical microinstructions). The valid selection keys are 
as follows: 

flonum-flonum Both operands are flonums (immediate floating-point numbers). 

fixnum-flonum a-opnd is a fixnum and b-opnd is a flonum. 

flonum-fixnum o-opnd is a flonum and b-opnd is a fixnum. 

extnum-extnum Both operands are extended numbers (anything other than fixnum 

or flonum, including bignums, rationals, extended-precision floating- 
point, complex, or what have you.) 



4,887,235 
703 704 



Traps - 22 3600 Microcode 



fixnum-extnum 
extnum-fixnum 
flonunv-extnum 
extnum-flonum These are analogous. 

fixnum-fixnum Both operands are fixnums, but a trap occurred anyway. This 

happens if overflow checking is enabled and an overflow occurs (see 
add-checking-overflow, page 26). 

If b-opnd is an extended number, it does not get fully type-checked; the trap handler 
fthould check the type again with check-data-type. This is because the hardware only 
has full data type checking capability on the Abus. It only checks b-opnd for being a 
fixnum; anything not a fixnum will trap and dispatch. Thus it is possible for the 
Otherwise clause to be reached with b-opnd having a random data type, and for an 
xxr-^xtnum clause to be reached with b-opnd having something whose data type is not 
dtp-extended-number. 

check-fixnum-larg-a a-oprid clauses... Micro 

Analogous to check-fixnum-2args when there is only one operand and it is on the 
Abus. If dispatching into a set of trap, handlers is used, the dispatch hardware will still 
think it is dispatching on two arguments; write the dispatch selectors in the clauses 
appropriately. 

check-fixnum-1arg-b b-opnd clauses Micro 

Analogous to check-fixnum-2args when there is only one operand and it is on the 
Bbus, If dispatching into a set of trap handlers is used, the dispatch hardware will still 
think it is dispatching on two arguments; write the dispatch selectors in the clauses 
appropriately. 

Beware! The "condition" bit in the type map is spuriously enabled to cause a trap. Thus 
check-fixnum-larg-b should not be paralleled with the data-type? predicate, nor 
with transport or store-contents. 

check-fixnum-b b-opnd ^optional trap-handler Micro 

Trap if b-opnd is not a fixnum; it must be a Bbus operand, trap-handler defaults to signal 
a data-type error; it may be specified as a microcode expression to handle the trap, or as 
nil to allow the trap handler to be supplied by something else in the instruction (typically 
a trap-if). This latter feature is used by array referencing, which simultaneously checks 
that the subscript is within bounds and that it is a fixnum— this would normally be done 
with trap-lf and check-data-type, but check-data-type requires its operand to be on 
the Abus. 

Beware! The "condition" bit in the type map is spuriously enabled to cause a trap. Thus 
check-fixnum-b should not be paralleled with the data-type? predicate, nor with 
transport or store-contents. 
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check-data-type-and-dispatch {o-opnd types,,.) clauses.,. Micro 

If the data type of o-opnd is one of the types named, take a trap. The trap handler is 
obtained by dispatching into clauses as with check-fixnum-larg-a. Note that the trap 
occurs if the operand is of the specified type(s), not if it fails to be of the specified 
type(s)— this \s the opposite of check-data-type. This micro is probably used only by 
the eql function (it is a different combination of the same primitives that the other micros 
above use). 

$S Delay 

nop Micro 

A microinstruction that does nothing. This is useful when an explicit delay is required 
(usually in connection with main memory). 

5.6 Trap Handlers 

There are two kinds of traps, and [ the trap 

handler is entered slightly differently depending on which kind occurs. Low-level traps trap to fixed 
addresses and save both NPC and CPC, permitting the trapped microinstruction to be retried. 
NPC is automatically pushed on the microcode subroutine stack by the hardware. CPC is saved in 
NPC where it is available to be saved by the trap handler (see the trap-save micro below.) 

The rest of the traps, such as those generated by trap-lf and check-fixnum-2args, trap to 
a trap handler whose address is freely specifiable, and do not save NPC. Thus the trapped 
microinstruction cannot be retried. However its address is still available to be saved by trap-save. 

trap-save Micro 

Finish the state save initiated by the trapping hardware, by pushing NPC onto the stack. 
NPC contains the original CPC, i.e. the address of the microinstruction that traps. NPC at 
the time of the trap has already been pushed onto the stack. This micro should be 
included in the first microinstruction of any trap handler that may retry the trapped 
microinstruction, or that needs to know where it came from. 

trap-no-save Micro 

Pop the saved NPC off the stack. This micro is included in the first microinstruction of a 
trap handler that is not going to retry and does not want extra words on the stack. Most 
commonly trap-no-save is used when a trap is being used as a simple jump. 



traf>-restore cycle-1 cycle-2 Micro 

Return from a trap handler and retry the microinstruction that trapped. Since this takes 
two cycles, trap-restore takes two arguments, which are microcode to be executed in 
parallel with the restore. First the saved CPC is popped into NPC. Then the saved NPC 
is popped into NPC and simultaneously CPC is loaded from I^C. 
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6. Machine Operations 

This chapter documents a host of micros that provide access to the various features of the 
machine. Many of these micros deal with data manipulation and hence expand into a datum rather 
than a statement; in other words they are used in an applicative style rather than the imperative 
style of most of the micros described above, 

6JL A and B memory 

a-constant value Micro 

value is a Lisp form to be evaluated; its value must be an integer. The a-constant micro 
expands into a datum which is an A-memory location containing that integer. 

b-<onstant value Micro 

value is a Lisp form to be evaluated; its value must be an integer. The b-constant micro 
expands into a datum which is a B-memory location containing that integer. 

amem address Micro 

A datum which is an A-memory location as specified by address^ which may be any of the 
following: 

location An integer between and 7777 is an absolute address. Normally defareg 

is used to give symbolic names to A-memory locations, rather than using 
explicit numbers. 

(frame-pointer offset) 
(stack-pointer offset) 

(xbas offset) The specified base register is added to the specified offset (an 8-bit signed 
integer) to compute the address. 

(macrocode) The address field of the current macroinstruction specifies a base register 
and an ofl'set. Normally the address-operand atomicro is used for this. 

stack-pointer Atomicro 

The stack-pointer register. This is a 28-bit up/down counting register, the low 10 bits of 
which also serve as a base register for A-memory addresses. 

frame-pointer Atomicro 

The frame-pointer register. This is a 28-bit register, the low 10 bits of which also serve as 
a base register for A-memory addresses. 

*b3S Atomicro 

The extra base register (this can only be written, not read). This is a 10-bit base register 

for A-memory addresses. 
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increment-stack-pointer Micro 

Add one to the stack-pointer. 
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decremant-stack-pointer Micro 

Subtract one from the stack -pointer. 

•tack-adjustment Atomicro 

A 4-bit register which increments and decrements in parallel with the stack -pointer, and is 
zeroed at the start of each macroinstruction. This makes it possible to restore the stack- 
pointer when aborting a trapped macroinstruction; see section 7.5, page 49. 

clear-stack-adjustment Micro 

Zero the atack-adjustment register. This is used when a complex macroinstruction 

reaches an intermediate point to which it can be aborted, usually together with the first- 
partKione flag. 

6.2 Arithmetic/Logic Unit 

A variety of micros are provided to perform arithmetic and logical operations on 1, 2, or 3 
operands (in the 3-operand case, the third operand must be the constant 1; thus x+y+1 and x-y-1 
may be computed.) The compiler allows more flexibility about the sources of these operands than is 
usual. The hardware takes one ALU operand from the Xbus and the other from the Ybus (via 
the shifter and AluB). Usually Xbus comes from Abus and Ybus comes from Bbus, however the 
reverse is also possible and m addition Xbus and Ybus each have a special source (Xbus may come 
from the multiplier, Ybus may come from the "crocks".) 

The compiler allows either operand to a 2-operand ALU micro to come from either bus, 
provided only that the two operands come from different busses so that the operation is physically" 
realizable. The exception is subtraction, for which the hardware is deficient: the minuend must 
come from the Xbus and the subtrahend from the AluB; thus it is not possible to extract a byte 
and subtract something from it (one could, however, add a negative constant to it.) 

The compiler allows the operand to a 1-opcrand ALU micro to come from either bus; in the 
cases where the hardware is deficient the compiler will turn it into the 2-operand case, supplying a 
constant operand on the other bus. 

Thus usually the programmer need only be careful to avoid trying to do an ALU operation on 
two Abus operands or two Bbus operands; the other vagaries of the hardware will be hidden by 
the compiler. 

Note that ALU operations are on 32 bits. The output-tagging feature (see section 6.7, page 
32) must be used to add a data-type tag. 

When no ALU operation is being performed, but a datum is simply being moved from one 
place to another, the compiler will generate the appropriate microinstruction to pass the datum 
unchanged through the ALU and to pass the tag around the ALU; thus all 36 bits will be moved. 
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Add I to opnd, 

^" ^^''^ Micro 

Subtract 1 from opnd. 

♦ opnd opnd ^optional opnd Micro 

Take the sum of two operands. If three operands are used, the third must be the constant 
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- opnd ^optional opnd opnd Micro 

With one operand, take the 2's-complement (negation). With two operands, take the 
difference. With three operands, the third must be the constant 1 and the result is the 
diflference, minus one. 

commutative-dlff opnd opnd ^optional opnd Micro 

The same as - except that the compiler is permitted to interchange the operands, reversing 
the sign of the result. This is normally used only when all you care about the result is 
whether or not it \s zero. 

logand opnd opnd Micro 

Bit-by-bit logical and. 

logior opnd opnd Micro 

Bit-by-bit logical inclusive or. 

logxor opnd opnd Micro 

Bit-by-bit logical exclusive or. 

lognand opnd opnd Micro 

The complement of logand. 

andc2 opndl opnd2 Micro 

logand with opnd2 complemented. 



inc-checklng-overflow opnd Micro 
1 + with overflow checking enabled. See check-fixnum-2args (page 21). 

dec-checking-overllow opnd Micro 
1- with overflow checking enabled. 

add-checklng-overflow opnd opnd Micro 

+ with overflow checking enabled. The 3-operand case is not allowed because the 
hardware cannot handle it. 
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sub-checkJng-overtlow opnd opnd Micro 

- with overflow checking enabled. The l-operand and 3-operand cases are not allowed 
because the hardware cannot handle them. (The 1 -operand case may be simulated by using 
a constant as the first operand.) 

63 Predicates 

The micros in this section expand into conditions which may be used with If and trap>-iL- 
Almost aU of them use the ALU and have the same constraints (or lack of constraints) on their 
operands as the arithmetic and logical micros in the previous section. 

not predicate j^^^^^ 

Reverse the sense of predicate, which must expand into a microcondition primitive. 
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The following predicates operate on 28-bit unsigned numbers (vinual addresses): 

equaf-pointer x y Micro 

True if the low 28 bits of x and y are equal. 

not-equal-pointer x y Micro 

True if the low 28 bits of x and y are not equal. 

greater-pointer x y Micro 

True if X is greater than y in the low 28 bits. 

greater-or-equal-polnter x y Micro 

True if x is greater than ^ in the low 28 bits, or they are equal. 

lesser-pointer x y Micro 

True if x is less than ^ in the low 28 bits. 

lesser-or-equal-polnter x y Micro 

True if X is less than y in the low 28 bits, or they arc equal. 

The following predicates operate on 32-bit signed 2's-complement numbers (fixnums): 

•qual-fixnum x y Micro 

True if the low 32 bits of x and y are equal 

not-equal-fixnum x y Micro 

True if the low 32 bits of x and y are not equal. 

greater-flxnum jc y Micro 

True if X is strictly greater than ^^ as a 32-bit 2's-complement number. 

greater-^r-equal-fixnum x y Micro 

True if X is not less than ^ as a 32-bit 2's-complement number. 
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iesser-flxnum x y Micro 

True if X is strictly less than / as a 32-bit 2's-complement number. 

lesser-or--equaMixnum x y Micro 

True if X is not greater than j^ as a 32-bit 2's-complemcnt number. 

zero-fixnum x Micro 

True if the low 32 bits of x are zero. 

not-zero^fixnum x Micro 

True if not all the low 32 bits of x are zero. 

minua-fixnum x Micro 

True if bit 31 of x is 1 (i.e. x is negative as a 32-bit 2's-complement number). 

minua-or-zero-*fixnum x Micro 

True if X is negative or zero as a 32-bit 2's-complement number. 
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plus-flxnum x Micro 

True if jc is strictly greater than zero as a 32-bit 2'5-coinplement number. 

plud-or-zero-flxnum x Micro 

True if X is greater than or equal to zero as a 32-bit 2's-complement number, i.e. bit 31 of 
X is 0. 

bit-test X y Micro 

Like the bit-test Lisp function, this is true if there is some bit position (among the low 
32 bits) in which x and y are both 1. 

idb-bit-test opnd bihnumber Micro 

True if the bihnumber^^ bit from the least-significant end of opnd is L bit-number is 
either a number between and 31. or the symbol byte-r. 

bit byie-field Micro 

byte- field must be a datum that is 1 bit wide. The condition )s true if the bit is 1. (bit 
x) is the same as (zero-fixnum x), when x is a 1-bit field, but leaves the ALU free and 
is a little faster. 

ail-ones x Micro 

True if the low 32 bits of x are all 1 (x is -1 as a 32-bit 2's complement number). 

The following predicates operate on 32-bit unsigned integers. There is no such data type in Lisp, 
but unsigned numbers are used internally in some parts of the microcode, such as floating point. 
Some of the predicates listed above (equal-fixnum for example) are equally meaningful for signed 
and unsigned integers. 

greater-fixnum-unsigned x y Micro 

True if X is greater than ^ as a 32-bit unsigned integer. 
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greater-or-equal-flxnum-unsigned x y Micro 

True if X is greater than >^ as a 32-bit unsigned integer or they are equal. 

lesser-fixnum-unsigned x y Micro 

True if X is less than y 2S z 32-bit unsigned integer. 

lesser-or-equal-fixnum-unsigned x y Micro 

True if X is less than y zs z 32-bit unsigned integer or they are equal. 

The following predicates operate on typed pointers, which are 34 bits (either 2 bits of type and 32 
bits of data or 6 bits of type and 28 bits of address). 

equai-typed-pointer x y Micro 

True if the low 34 bits of x and y are equal. 

not-equal-typed-pointer x y Micro 

True if the low 34 bits of x and y are not equal. 

The following predicates are miscellaneous. 
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ybU8-31 Atomicro 

True if the sign bit of the Y bus is 1. This is used by the micrcx^e for division, but 
' probably is not useful for anything else. This predicate must be parallered with 
something that puts data on the Y bus. 

alu-carry Atomicro 

True if there is a carry out of bit 31 of the ALU. This is useful when doing multiple- 
word integer arithmetic. This predicate must be paraltePed with something that does an 
ALU operation. 

micro-stack-empty Atomicro 

True if this is the emulator task and the control stack is empty. 
(This only exists in the pre-prototype hardware.] 

data-type? operand types... Micro 

True if operand (which must be an Abus source) has a data type whose name is one of 
the specified types, 

not-data-type? operand types,.. Micro 

True if operand (which must be an Abus source) has a data type whose name is not one 
of the specified types. 

cdr-code? operand code Micro 

True if operand (which must be an Abus source) has the specified cdr code, code may be 
cither the name of a cdr code or a number from to 3. 

not-cdr-code? operand code Micro 

True if operand (which must be an Abus source) does not have the specified cdr code. 
code may be either the name of a cdr code or a number from to 3. 

See also odd-pc? (page 41), Ibus-dev-cond (page 36), and sequence-break (page 34). 



Storing Results 30 3600 Microcode 



6.4 Storing Results 

assign destination source Micro 

source is any datum, and destination is a datum that can be stored into. A statement is 
generated to store source into destination, assign knows how to store into all the 
memories and registers in the machine, and also knows how to store into byte fields in a 
register or memory location. Note however that assign is not usually used with main 
memory, because of garbage collector storage conventions; see store-contents (page 38). 

obus Atomicro 

A datum that stands for whatever is on the Obus (the output from the data path). This \s 
useful shorthand when storing the result of the same computation into more than one place 
simuluneously. 

6^ Shifter 

byte-mask ppss 

A Lisp function that converts a byte pointer to an integer containing 1 bits in the selected 
byte and bits elsewhere. This function is useful in connection with the a-constant and 
b-constant micros. 



4,887,235 
719 720 

Idb operand n-biis biis-over &optional background Micro 

Expands into a datum which represents a byte extracted from operand, n-bits is the width 
- of the byte, bits-over is the bit number of the least significant bit in the byte (in other 
words, the number of bits between the byte and the least-significant end of operand). If 
background is specified, it is a datum which supplies the bits of the result outside of the 
byte; normally these bits are 0. If background is the number 0, that is the same as no 
background. 

n-bits is a number from 1 to 40, or the symbol byte-s, or the symbol macro, byte-s 
means that the byte-s register contains one less than the number of bits, macro means 
that the macroinstruction specifies the byte size. 

bits-over is a number from to 37, or the symbol byte-r, or the symbol macro, byte-r 

means that the byte-r register contains the number of bits of left rotation (40 minus the 
bits-over), macro means that the macroinstruction specifies the left rotation. 

Not all combinations of non-numeric values for n-bits and bits-over zxt supported by the 
hardware; the compiler will complain if you try to do something illegal. 

Strange-ldb operand n-biss bits-over ^optional background Micro 

This is the same as Idb except with some error-checking turned off. This allows you to 
use bytes that cross the word boundary and exploit what the hardware does in this case. 
(The hardware acts as if it first rotates right by bits-over and then masks with a mask n- 
bits wide,) 



3600 Microcode 31 Multiplier 

dpb operand n-bits bits-over background Micro 

Expands into a datum which represents the result of depositing the low bits of operand into 
a byte in background, n-bits is the width of the byte and bits-over is its position. 
background is cither an operand or the number 0, which means that the bits in the result 
outside of the byte field should be 0. 

n-bits is a number from 1 to 40, or the symbol byte-s, or the symbol macro, byte-s 
means that the byte-s register contains one less than the number of bits, macro means 
that the macroinstruction specifies the byte size. 

bits-over is a number from to 37, or the symbol byte-r, or the symbol macro, byte-r 
means that the byte-r register contains bits-over (the number of bits of left rotation). 
macro means that the macroinstruction specifies the byte position. 

Not all combinations of non-numeric values for n-bits and bits-over are supported by the 
hardware; the compiler will complain if you try to do something illegal. 



rotate operand amount Micro 

Rotate operand (as a 32-bit number) left by amount places, amount may be a number 
from to 37 or the symbol byte-r. 

complemented-sign-blt operand Micro 

A 1-bit byte which is the complement of bit 31 of operand. The background is always 0. 
Thus the result is if operand is negative, or 1 if operand is positive or zero. 
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by*^^ Atomkro 

A 5-bit register which can be used as a source of left-rotation for the byte hardware. 
- byte-r can be written from the Obus in the usual manner, or the special statement 
(assign byjLe-r (array-1ndex-shift-prom)) 
may be done in parallel with a dispatch-after-next to load byte-r with a function of 
the field being dispatched upon. This feature is provided specifically to speed up the 
accessing of packed arrays of bytes and is probably not generally useful. 

byte-8 Atomicro 

A 5-bit register which can be used as a source of byte-size-minus-l for the byte hardware. 

6.6 Multiplier 

write-mpy-x source ioptional signed Micro 

Writes the low 16 bits of source into the X register of the multiplier. If signed is non-nil, 
bit 15 of source is taken to be a 2's-complement sign bit; otherwise the X register is 
unsigned, source comes in through the Xbus. 



Output Tagging 32 3600 Microcode 



write-mpy-y-from-high source ^optional signed Micro 

Writes bits 31-16 (the high 16 bits of a fixnum) of source into the Y register of the 
multiplier. If signed is non-nil, bit 31 of source is a 2*s-complement sign bit; otherwise the 
Y register is unsigned, source comes in through the Ybus, thus it may be shifted (with 
Idb, dpb, or rotate) simultaneousiy. The multiplier stts the unshifted data. 

mpy-product Atomicro 

The 32-bit product of the X and Y registers. This is an unsigned fixnum if both X and Y 
were unsigned; otherwise it is a signed fixnum. mpy-product is read onto the Xbus. The 
product may be read in the immediately following microinstruction after loading one or 
both of the multiplier's input registers; the mpy-product atomicro includes the necessary 
timing specification. 

6.7 Output Tagging 

These micros control the tag fieJds of the output from the ALU. When an ALU operation is 
performed, the tag fields are indeterminate unless these micros are used. When the ALU is just 
used to pass an Abus or Bbus source, the tag fields come from that source. 

eet-cdr operand cdr Micro 

Expands into a datum which represents operand with its cdr code set to cdr. cdr may be 
the symbolic name of a cdr code or a number from to 3. 

set-type operand type Micro 

Expands into a datum which represents operand with its data type set to type^ which must 
be the symbolic name of a data type. If type is dtp-fix or dtp-float, 32 bits of operand 
are used; otherwise only 28 bits of operand appear in the output. 

merge-cdr operand cdr-background Micro 

A 36-bit datum which consists of the cdr-code field of cdr-background and the type and 
pointer fields of operand. 
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See section 7.4, page 48 for some other related micros. 

6.8 Special Sequencer Controls 

halt reason j^fcro 

Stop the machine after executing this microinstruction, reason is put in a table for the 
FEP to use. 



popj-into-npc Micro 

Pops the top word off the control stack and puts it into the NFC register. 
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pop-control-stack Micro 

Pops the top word off the control stack and returns it as a datum; also puts it into the 
NPC register. Only the low 14 bits of the datum are valid. The rest contain other things; 
however a Idb operation to mask it off cannot be paralled with pop-control^tack due 
to hardware limitations. It is possible to mask it off by log an ding ft with a b-constant. 

csp Atomicro 

The control-stack pointer. This is a 4-bit read-only register. It takes two 2 cycles to read 
it. 

The long-dispatch micro, which writes into the NPC register from the data path, also comes 
under this category. See page 19. 

6.9 Datapath Control Register 

w rite-dp-control datum Micro 

Write datum into the control register on the DP board. The bits in this register control 
various random things: 

bits 1-0 The stack base. This supplies bits 11-10 of the A-memory address when 

the address is computed as an offset from stack-pointer, frame-pointer, or 
xbas. 

bit 2 The sequence break flag. This is a testable condition and also if it is 1 the 

IFU traps instead of supplying the next instruction. 

bits 3,4 Trace flags 1^. These are testable conditions with no special hardware 

features. 

sequence-break Atomicro 

A predicate which is true if the sequence break flag is on. 

trace-flag-1 Atomicro 

A predicate which is true if trace flag 1 is on. 
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trace-flag-2 Aromicro 

A predicate which is true if trace flag 2 is on. 

6.10 Lbus Microdevices 

These micros provide primitive microdevice operations. Usually each device will have specific 
micros for its operations defined in terms of these. 

read*Ibu8--dev card subdevice Micro 

A datum which is a word read from the specified microdevice. subdevice is a 5-bit number. 
card selects a card and is either a 5-bit backplane slot number or a symbolic card name, in 
which case the FEP determines the backplane slot number when the microcode is loaded. 
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write-tbus-dev card subdevice datum Micro 

Write datum into the specified microdevice. subdevice is a 5-bit number, card selects a 
card and is either a 5-bit backplane slot number or a symbolic card name, in which case 
the FEP determines the backplane slot number when the microcode is loaded. 

select-lbus-dev card subdevice Micro 

Select a microdevice without doing anything to it. This is normally used internally by 
other micros, subdevice is a 5-bit number, card selects a card and is either a 5-bit 
backplane slot number or a symbolic card name, in which case the FEP determines the 
backplane slot number when the microcode is loaded. 

ibu8-dev^ond Atomicro 

A predicate which is true if the Lbus Dev Cond line on the bus \s asserted. A 
read-lbus^ev or write-lbus-dev should be done in parallel to select a device. 

6J1 Main Memory 

Accessing memory requires interacting with virtual address mapping and with the garbage 
collector (since the garbage collector "watches" data pass between processor and main memory). 
Invisible pointers are also implemented here. 

•*Main memor>'" actually is anything on the Lbus that behaves like memory. This includes 
main memory itself, TV memory, and the control registers of "memory-mapped" I/O devices. The 
A memory in the datapath can also masquerade as main memory; the virtual address map can 
specify, instead of a physical address, one of the 16 physical pages of A memory. 

Conceptually there are two registers, vma (which holds a virtual address) and memory-data 
(which holds data passing to or from memory). Actually the memory is addressed by physical 
addresses; the physical address to be referenced may be the result of mapping the contents of vma 
from virtual to phN'sicai, which is the usual case, or may come directly from the Abus. This 
mapping is implemented by tables in main memory, cached in a hardware map cache. Furthermore 
if bits 28-24 of vma are all I's, vma contains a 24-bit physical address and the map is bypassed. 
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memory-data is not really a register, but represents the processor end of tw-o pipelines, one 
going into memory and one coming out of memory. 

In general, the timing of a memory cycle is: 

1) Load the virtual address into vma. 

2) Start the memory. If writing, simultaneously output the data to be written. This 
microinstruction traps if there is a map cache miss. 

3) One microinstruction of delay while the memory read is active. 

4) The memory read data are available as an operand. This microinstruction traps if 
there is a bad data type, an invisible pointer, or a transporter trap. 
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memory-data ^,^^.^^^ 

A datum which represents data read from memory. Assigning to this stores into memory- 
however usually store-contents (see page 38) should be used instead. 

^^^ Atomicro 

A datum which represents the 28.bit virtual address register. Assigning to vma stores a 
new address into the register but does not automatically start a memory cycle. 

Start-memory modes... j^^^^^ 

Start a memory cycle. The modes specified control the type of cycle to be started. Some 
mode symbols are followed by arguments. The following symbols may be used as modes: 
read Start a read. 

write Start a write. Either read or write must be specified. If both are specified, a 
read is started but write-access is checked in the map. If a write is started, the 
data to be written must be computed and placed on the Obus in parallel with this 
Start-memory. 

physical addr. 

Take addr as the physical address, instead of mapping the virtual address in vma. 
addr must be an Abus source. 

dma card subdevice 

Start a DMA cycle. The data read from memory or written to memory goes 
to/comes from an Lbus device instead of the processor data path, card and 
subdevice address the Lbus device; see select-lbus-dev (page 36). Must be used 
in combination with physical. 

inhlbit-page-tags 

Prevent the page tags from noticing this cycle. Must be used in combination with 
physical. 

address-phtc 

Get the physical address by mapping the contents of vma through the page-hash- 
table-cache hash box instead of the normal map. This mode can also be turned on 
automatically: when a map cache miss occurs, the hardware does 

(start-memory read address-phtc) 
instead of whatever start-memory was originally programmed, and traps to 
appropriate microcode. 

block Start or continue a block memory operation. This may not be used with any of 
the other modifiers except read or write, may not be used with both read and 
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write, and may only be used by the emulator task, block causes vma to be 
incremented, changes the reporting of map misses, and allows a new memory 
operation to be started every cycle. 

declare-memory-timing state Micro 

Declare that the current microinstruction (everything paralleled with the 
decia re-memory-timing) occurs with a memory read in state^ which is either 
active-cycle or data-cycle. The microcode compiler follows the timing of memory 
reads and gives an error message if memory-data is accessed at a time when it is not 



Main Memory 38 3600 Microcode 



valid. This micro is provided to turn off such error messages when the compiler cannot 
follow the timing (for example, when a subroutine is called with a memory cycle already 
started). Be sure that you know what you are doing, and don't turn off error messages 
that are telling you about genuine errors. 

Store-contents ra/i/e ^optional cdr not-o-pointer Micro 

Store lvalue into the currently-addressed memor>' location (the location vma points to, 
which in most cases will just have been read to check for invisible pointers). 
store-contents puts the word to be stored on the Obus and does a (start-memory 
write) to cause it to be stored. If other memory modes than just write are required, an 
explicit start-memory may be paralleled with the store-contents. 

If cdr is unspecified or nil, the cdr code comes from ra/x/e; otherwise cdr is a number 
from to 3, the name of a cdr code, or a data source whose cdr code is to be used 
(usually memory-data, when the location being stored into has just been read and its cdr 
code is to be preserved). 

If not'Chpointer is unspecified or nH, value is a Lisp datum; it is decoded by the type map 
and the GC map (consequently it must be an Abus source) to see whether it is a pointer 
and if so what it points at. This may cause GC page tags to be set and may cause a gc- 
write-trap if a pointer to a stack is being stored. 

If not'O-pointer is t, value is simply stored; for system storage conventions to be met, value 
must be guaranteed to have a non-pointer data type (typicaUy fixnum). This case is 
identical with assigning to memory-data, except for the cdr-code control and the 
automatic (start-memory write). 

mem read address Micro 

Assigns address to vma and calls a subroutine which starts a read and returns with the 
data available in memory-data. Use this if you don't have anything useful to overlap 
with the wait for memory; it will conserve control memory locations. 

transport &optional type Micro 

Use this before or at the same time as picking up data read from memory. 
memory-data is read onto the Abus and decoded by the type and GC maps. A trap 
occurs if the word read from memory is an invisible pointer, has an invalid data type, or 
is a pointer to oldspace. The trap handler may restart the memory reference using a new 
address (e.g. if an invisible pointer is followed); in this case the new address will be stored 
into vma and b-vma, and the microinstruction containing the transport will be 
reexecuted. (b-vma is purely a software convention.) 

type specifies the type of transport desired. It must be one of the following symbols: 



data 



write 
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This is the default. The word read from memory is going to be xised as 
data (i.e. as a Lisp object.) All invisible pointers are followed, oldspace 
pointers are detected, and an error occurs if the data type is null (unbound 
variable) or header (internal data structure scaffolding not valid as a Lisp 
object). 

The memory read was only done in preparation for a write. All invisible 
pointers are followed, but no oldspace checking is done and there is no 
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Virtual Address Map 



error if a null pointer is detected. A header type causes an error. 

cdr The car of a cons is being accessed by the cdr function, not as data but 

only to check its cdr code. Only header-forward and body-forward invisible 
pointers are followed and there is no oldspace check. A header type causes 
an error. 

header The word read from memory is expected to be the header of a structure. 

Header-forward invisible pointers are followed, an oldspace check is done, 
and data types illegal as headers signal an error. 

bind The memory location is a cell being bound (e.g. a special-variable value 

cell). All invisible pointen except external-value-cell-pointer are followed, 
an oldspace check is done, and a header type causes an error (a null type 
does not). 

bind-write The memory location is a cell whose binding is being restored. All invisible 
pointers except cxternal-value-cell-pointer are followed, no oldspace check is 
done, and a header type causes an error (a null type does not). 

»cav The memory reference is being performed by the scavenger. An oldspace 

check is done, but there are no invisible pointers and no data type error 
checks. 



Data type errors are signaUed via trap-0 from the type map. Invisible pointer following 
uses trap-2. If there is an invisible pointer to oldspace, the oldspace trap takes priority; 
the invisible pointer will be followed when the transport is retried after the garbage 
collector has had its say. 

b-vma Atomicro 

By software convention, b-vma (a B-memory location) sometimes contains a copy of the 
vma register. The transporter does not depend on the contents of b-vma, but if it 
changes vma it also stores the new value into b-vma. The data type is indeterminate. 
b-vma exists to make it possible to combine (add or compare) the address in vma with 
data from the Abiis. 
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Instruction Fetch Unit 

As explained in the Flow of Control chapter, a subroutine return from the outermost 
microcode subroutine in the emulator task transfers control to the address supplied by the 
Instruction Fetch Unit (IFU). This is usually written (next-instruction), although (return) is 
the same. The address is either the address of the microcode to execute the next macroinstruction, 
derived from its opcode, or the address of a trap routine (to handle a cache miss, page turn, or 
sequence break). If the IFU is not ready with the next address, it causes the processor to wait. 



In addition to this dispatching feature, the IFU maintains current macroinstruction and 
program counter (PC) registers. The low 8 bits of the current macroinstruction are accessible on 
the data path as an operand, may also be used in the A-memory address calculation, and may be 
incremented. 

macro-unsigned-immediate Atomicro 

A datum containing the macroinstruction immediate field in bits 7-0, zero in bits 31-8, and 
fixnum data-type in bits 33-32. This is a Bbus source. 

macro-signed-immediate Atomicro 

A datum containing the macroinstruction immediate field in bits 7-0, a copy of bit 7 in 
bits 31-8, and fixnum data- type in bits 33-32. This is a Bbus source. 

increment-mac ro-immediate Micro 

Adds one to bits 7-0 of the current macroinstruction. This is useful when it addresses a 
multi-word A-memory operand. 

There are two macroinstructions per 36-bit word. Consequently the PC must specify a word 
address and a halfword-select bit. The PC is represented as a 28-bit word address with a data type 
tag field of 60 (dtp-even-pc) for the even haifword or 70 (dtp-odd-pc) for the odd halfword. 
The PC hardware is capable of incrementing in this format. This form of PC is called a word-pc\ 
another useful form is simply a 29-bit halfword address, called a halfword-pc. The encodings of 
dtp-even-pc and dtp-odd-pc and the high bits supplied when the PC register is read are chosen 
in such a way that conversion between halfword-PC and word-PC may be done in a single 
microinstruction using the existing data paths (basically rotating a 32-bit word by one bit position). 
This facilitates arithmetic on PC values. 
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pc Atomicro 

The current PC, i.e. the address of the next macroinstruction after the one currently 
executing. This is a word-pc. 

Assigning to pc is usually done with the set-pc micro (see below), which knows how to 
get the IFU working on the new instruction stream. In any case assigning to pc also 
assigns to vma. 

half word-pc word-pc Micro 

Translates a word-pc into a halfword-pc. The halfword PC appears at one of the inputs to 
the ALU, so a number may be added to it in the same microinstruction. 

word-pc halfword-pc Micro 

Translates a halfword-pc into a word-pc. 
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Odd-pc word-address Micro 

Translates word-address into a pc (word-pc) that points at the second instruction in that 
word. 

odd-pc? pc M^^,^ 

A predicate which is true if the operand pc points to the second instruction in a word" 
(false if it points to the first instruction). 

pc-plus-number base-pc offset j^i^ro 

Add offset, a positive or negative number of haifwords, to base-pc, a word-pc value. This 

micro expands into a datum which is the resulting word-pc value, and takes 2 c>xles to 
execute. 

pc^add base-pc magic-offset Micro 

Add magic-offset, a halfword offset in the magic hardware-dependent format used by 
branch instructions, to base-pc and return the resulting word-pc. Unlike pc-plus-number 
this takes only one cycle to execute. 

magic-offset, arithmetically shifted right by one bit, is the word offset and is added to the 
28-bit pointer field of base-pc. The least-significant bit of magic-offset is the halfword 
select; it is added to the halfword-select bit of base-pc, however there is no carry from 
this addition into the word address. Furthermore, if magic-offset is negative, there is a 
carry into the halfword select addition which has the effect of complementing the least- 
significant bit of magic-offset. 

set-pc new-pc &optional other-code Micro 

Assign new-pc (a word-pc value) to the hardware PC register, synchronize with the IFU, 
and do a (next-Instruction). If other-code \s specified, it is microcode to be executed in 
parallel with the wait for the IFU. 

increment-pc Micro 

Advances the hardware PC (and the IFU) to the next instruction. 
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increment-fake-pc Micro 

Advances the simulated PC to the next instruction; takes 2 cycles. 



Tasking 



cur-task Atomicro 

The current task number. This is a 4-bit read-only register. It takes two 2 cycles to read 
it. 

dismiss Micro 

Dismiss the current task. It will execute one more microinstruction and then stop executing 
until it is awakened again. 
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wakeup-task n Micro 

Wake the specified task, n must be the number of a software-awakened task: 1, 2, 5, or 
'6. 

w rite-task-state n falue Micro 

Write the saved state of task n (a constant number from to 17, or a Bbus source whose 
low 4 bits are used) with the 32-bit datum value, 
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3600 Microcode 45 Architectural Stuff 

7. Architectural Stuff 

This chapter describes micros which implement the Lisp architecture. 

7J The Stack 

The top few pages of the Lisp stack, including the entirety of the current frame, are stored in 
a part of A memory known as the stack buffer. The stack-pointer and frame-pointer registers 
contain the virtual addresses of the top of the stack and the current frame, respectively; these 
same registers, used as A-memory base registers, address the A-memory locations containing those 
virtual addresses. 

The stack may also be addressed as normal virtual memory; references to those pages currently 
residing in the stack buffer are automatically redirected to A memory. 

The top word of the stack is duplicated in a B-memory location. This makes it possible to ' 
feed the top two words on the stack, or the top word on the stack and some location in the 
current frame, into the ALU as a pair of operands. 

top«of-stack Atomicro 

The B-memory location containing the top word on the stack. 

top-of-stac k-a Atomicro 

The A-memory location containing the top word on the stack. This is a more concise way 
of saying (amem (stack-pointer 0)). 

next-^n-stack Atomicro 

The A-memory location containing the next-to-top word on the stack. This is a more 
concise way of saying (amem (stack-pointer -1)). 

address--operand Atomicro 

The A-memory location addressed by the current macroinstruction. This is a more concise 
way of saying (amem (macro)). 

The following micros are used to maintain the stack, taking care of the convention that the top 
word is stored in both A and B memories. 
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pushval value Micro 

Pushes value onto the stack, with a cdr code of cdr-next. The stack-pointer \$ incremented. 
- This is the standard way to store the result of an instruction (when there are'loo" 
arguments to be popped off). 

newtop value Mi^ro 

Puts value into the top of the stack, with a cdr code of cdr-next. The previous top of the 
stack is replaced, and the stack-pointer does not change. This is the standard way to store 
the result of an instruction that pops one argument and pushes one result. 
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pop2push value Micro 

Effectively pops the stack twice and then does a pushval, but docs it all in a single 
microinstruction. This is the standard way to store the result of a microinstruction that 
pops two arguments and pushes one result. 

Popval Micro 

Expands into a datum which is the word on the top of the stack (as a Bbus source). As a 
side-effect, the stack is popped; i.e. the stack-pointer is decremented and the B-memory top- 
of-stack register is updated. 

pushval-with-cdr value Micro 

Identical to pushval except that value'% cdr code is preserved (pushval always sets the 
cdr code of the stack location to cdr-next). value will normally be a set-cdr expression. 

newtop"With-cdr value Micro 

Identical to newtop except that valuers cdr code is preserved (newtop always sets the cdr 
code of the stack location to cdr-next). value will normally be a set-cdr expression. 

IJl Standard A and B Registers 

A large number of registers are set up by the Sysdfl file and will not be discussed here. 
a-temp, a-temF>-2, b-temp, b-temp-2, b-temp-3, and b-tem;>-4 are general-purpose 
temporary locations. Other A & B registers set up by UA are too specialized to bother with here. 

12 The Current Stack Frame 

The atomicros in this section define various fields in the header of the current stack frame. 

frame-function Atomicro 

The currently-executing function. 

frame-misc-data Atomicro 

A fixnum full of various fields. Accessors for these fields are defined below. 

frame-return-pc Atomicro 

The return PC of this frame's caller. 

frame-previous-top Atomicro 

The address of the top of the previous frame; this is put into stack-pointer when the 
current frame returns. The cdr code of this word is the value disposition code. 
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trame-previous-frame Atomicro 

The address of the previous frame; this is put into frame-pointer when the current frame 
- returns. 

Fields in frame-misc-data. 
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frame-number-of-args Atomicro 

The number of arguments supplied when this frame was called. 

frame-cleanup-bits Atomicro 

If this field is not zero, extra work needs to be done when this frame returns or \s thrown 
through. 

frame-buffer-underflow-bit Atomicro 

1 if the previous frame is not entirely in the stack buffer. 

frame-unsafe-reference-bit Atomicro 

1 if there arc pointers to this frame. 

frame-catch-bIt Atomicro 

1 if there are catches or unwind-protects in this frame. 

frame-bindings-bft Atomicro 

1 if there is a frame on the binding stack associated with this frame. 



frame-trace-bit Atomicro 

1 if a trap to the debugger is requested when this frame is unwound (either by return or 
by throw). 

frame-bottom-bit Atomicro 

1 if this is the bottom frame in its stack; trap and do a stack-group-return if this frame 
tries to return. 

f 1 rst-pa rt-done Atomicro 

1 if an instruction running in this frame was trapped out of and is in an intermediate state 
(a few instructions look at this flag). 

frame-lexpr-called Atomicro 

I if this frame was called via apply or lexpr-funcalL The caller's copy of the arguments 
includes a list of arguments. 

frame-f uncalled Atomicro 

1 if this frame was called via funcail or a similar operation; the caller's copy of the 
arguments is in a slightly different place. 

frame-Jnstance-calied Atomicro 

1 if this frame contains a method called by sending a message to an instance. The first 
two local slots in the frame contain self and self-mapping-table. 

frame-argument-format Atomicro 

A 2-bit field consisting of frame-lexpr-called and frame-instance-called. 
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7.4 Tag Manipulation 

The micros described in this section are used to implement the subprixnitive instructions that 
manipulate the tag field in a Lisp "pK)inter." They are complicated by the fact that the tag field is 
of variable width: 8 bits normally, but 4 bits in fixnums and f^onums. 

cdr-field operand &optional background Micro 

A 2-bit datum which is the cdr code of operand^ an Abus source. If background is 
specified, it supplies the rest of the bits, as in Idb. 

high-type-field operand &optional background Micro 

A 2-bit datum which is the high 2 bits of the type field of operand j an Abus source. To 
extract all 6 tyoc bits, you must use low-tag-field separately and then combine the 
results. If background is specified, it supplies the rest of the bits, as in Idb. 

high-tag-field operand ^optional background Micro 

A 4-bit datum which is the cdr code and high type bits of operand^ an Abus source. If 
background )s specified, it supplies the rest of the bits, as in Idb. 

low-tag-fletd operand &optional background Micro 

A 4-bit datum which is the low 4 type bits of operand^ an Abus source. To extract all 6 
type bits, you must use high-type-field separately and then combine the results. If 
background is specified, it supplies the rest of the bits, as in Idb. 

pointer-field operand &optional background Micro 

A 28-bit datum which is the pointer field of operand^ an Abus source. If background is 
specified, it supplies the rest of the bits, as in Idb. 

dpb-tag-fieid tag pointer Micro 

A 36-bit datum containing tag in its tag field and pointer in its pointer field, tag is an 8- 
bit Bbus source and pointer is a 28-bit Abus source. 

dpb-tag-field-high-only tag fixnum Micro 

Like dpb-tag-fleld but only the high 4 bits of iht tag come from tag\ fixnum supplies 
the low 32 bits of the result. Note that the low 4 bits of tag are ignored and bits 7-4 are 
used. 

set-low-tag-field operand tag Micro 

A 32-bit datum containing operand in its low 28 bits and the constant number tag in its 
high 4 bits (the low 4 bits of the tag field). 

dpb-cdr-fieid tag operand Micro 

A 36-bit datum consisting of operand (an Abus source) with its cdr-code field replaced by 
tag. The hardware takes the cdr-code from bits 7-6 of Bbus, so tag is required to be a 
datum which extracts those bits from a Bbus source or the micro will signal an error. 
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dpb-type-fleSd tag pointer Micro 

A 34-bh datum consisting of tag in the data type field and pointer in the pointer field, tag 
- is a 6-bit Bbus sourct. pointer \s a 28-bit Abus source. 

7^ Traps 

These micros implement trapping out from microcode to macrocode. This includes doing 
something with the current PC, possibly resetting stack-pointer to its value at the beginning of the 
macroinstruction, emptying the microcode subroutine return stack, setting PC to point to the first 
macroinstruction of the trap handler, and re-entering macroinstruction processing. The trap handler 
is always an escape function, defined in the Sysdfl file. 

Aborting a macroinstruction is called pclsring in the microcode, by analogy with the 
corresponding issue in the ITS operating system. Think of it as a neologism with the same 
historical status as cdr, 

taka-pre-trap escape- function-name stack-control Micro 

Back out of the current instruction and trap to an escape function, stack-control is 
preserve-stack to leave stack-pointer alone or restore^stack to undo any pushes or 
pops that may have been done by this macroinstruction. The PC is decremented and saved 
on the stack, with a cdr code of cdr-normal as a clue to the debugger. The escape 
function may exit by popfing to that PC. 

take-post-trap escape- function-name stack-control Micro 

Trap to an escape function, logically after the current macroinstruction (the PC is not 
decremented), stack-control is preserve-stack to leave stack-pointer alone or 
restore-stack to undo any pushes or pops that may have been done by this 
macroinstruction. The PC is saved on the stack, with a cdr code of cdr-normal as a clue 
to the debugger. The escape function may exit by popf ing to that PC. 

take-jump-trap escape-function-name stack-control Micro 

Trap to an escape function without saving the current PC. stack-control Is 

preserve-^tack to leave stack-pointer alone or restore-^tack to undo any pushes or 
pops that may have been done by this macroinstruction. 

take-Jump-trap-with-continuatlon escape-function-name Micro 

continuation stack-control 
Trap to an escape function, pushing ^e 6zt\im continuation on the stack as its return PC, 
with a cdr code of cdr-ncxt. stack-control is preserve-stack to leave stack-pointer alone 
or restore-stack to undo any pushes or pops that may have been done by this 
macroinstruction. 

a-pclsr-top-of-stack Atomicro 

This A-memory location is used (by software convention) to assist in the restoration of the 
stack when pclsring (aborting a macroinstruction). If the contents of this register has type 
tag dtp-null, it is empty and has no effect. Otherwise it contains the value which should 
be restored on the top of the stack if we pclsr. This is used by macroinstructions which 
pop an argument off the stack and push something else on (smashing the argument) before 
they are sure that their execution will complete successfully. 

FEP PROGRAM 
F:>LMach>Fep>defword.in .15 



!;;-»• node: Lil; Package:Lit; 8ase:8.; Lowercase: T -«- 
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requires STREAH-DEFS to be loaded first. 



(defstreamfunction print-uord ( (uopd byte-ptr) (ud uord-descript ion) ) standard-output) 

(deftyse vaiue-names* (array string *) ) 
(deftype field-description-type (structure () 

(name string) 

(print-name boole) 

(ss byte) 

(pp word) 

(n-value-names word) 

(value-names value-names*))) 
(deftype field-description (pointer field-description-type auto-dereference t)) 
(defatcmmacro NULL-f ield-descr ipt ion * (make-null -pointer field-description)) 



(deftype pointer-to-uord-descr ipt ion (pointer word-description)) 

(deftype word-description-type (array field-description *) ) 

(deftype word-description (pointer word-description-type auto-dereference t)) 

(defatommacro NULL-word-descr ipt ton * (make-nul l-pointer word-description)) 



;for funcal l-for-value 



'true *false) 
(first f ietd-name) )) 



(deftilmacro defuord (name ignore «body field-descriptions) 
(loop with pp with ss with value-names 

for (type fieid-name . fd-rest) in field-descriptions 
for field-number upfrom 8 
do (if (I istp field-name) 

(setq print-name (if (second field-name) 
fieid-name (or (second field-name) 
(setq print-name 'true)) 
do (seiectq type 

(:byte (setq pp (second fd-rest) 
ss (first fd-rest) 
value-names (nthcdr 2 fd-rest))) 
(:bit (setq pp (first fd-rest) 
ss 1 
value-names (and (cdr fd-rest) 

(list (third fd-rest) (second fd-rest))))) 
(otherwise (warn "^-A is an unknown field type in defuord *A" type name))) 
' (make-pointer f te I d-descr ipt ion 

(constant fiei d-descr ipt ion- type 

name .(string field-name) 
pr i nt-name , pr i nt-name 
PP .PP 

ss ,8S 

n-value-names .(length value-names) 

value-names 

(constant value-names* 

,»(loop for vn in value-names 
col lect (if vn 

*♦ (string vn) 



col lect 



.•(if value-names 

into field-descriptions 

finally (return Mdefconst .name word-description 
(make-pointer word-description 

(constant word-descr ipt ion- type 
.•f ie I d-descr ipt ions 
NULL- f i e 1 d-descr i p t i on) ) ) ) ) ) 

F:>lmach>fep>Shared-def1 nit ions. 1 isp. 7 



•NULL-string)) 

' (NULL-string))))] 



-*- Package: LIL: flode: Lisp; PackogerLiI; Base: 8; Lowercase: Yes 



;;; Table of console-program/fep commands, 
(def const *f cn-to-opcode-mappings* 
;;: Fep function name 

'((018 process-read-version 
(110 process-wr i te-bytes 
(112 process-read-bytes 
(114 process-wr i te-uords 



L isp funct ion name 
read-version 
ur t te-bytes 
read-bytes 
write-words - 



In prom 



T) 
T) 
T) 
T) 
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(lis process 
(123 process 
:; Don' t cha 
(223 process 
(282 process 
(204 process 
(2C6 process 
(21B process 
(212 process 
(214 process 
(21S process 
; (220 proces 
(222 process 
(224 process 
(22B process 
(233 process 
(232 process 
(234 process 
(236 process 
(240 process 
(242 process 
(244 process 
(24B process 
(253 process 
(252 process 
(254 process 
(25G process 
(2B3 process 
(252 process 
(2B4 process 
(2BB process 
(273 process 
(272 process 
(274 process 
(275 process 
(333 process 
(332 process 
(304 process 
(3CB procecs 
(313 process 
(312 process 
(314 process 
(31B process 
(323 process 
(322 process 
(324 process 
(325 process 
(233 process 
(332 process 
(334 process 
(335 process 
(348 process 
(353 process 
(351 prccecs 
(352 process 
(253 process 
(354 process 
(355 process 
(35B procecs 
(357 process 
(353 process 
(3G1 process 
(352 process-i:r i te-c 
(3S3 process 
(3S4 process 
(3B5 process 
(3BE process 
(3G7 process 
(373 process 
(371 process 
(372 process 



-read-uords 

goto 
nge the assignments of any func 

ur i te-Ibus 
-uir i te- Ibus-and-ecc 

read- I bus 

read- Ibus-and-ecc 
-wr i te-lbus-block 
-reacf- Ibus-blocK 
-wr i te-f i xnums 
-read-f ixnun^s 
s-ur i te-cmem-wd 
-wr i te-uir 

read-uir 

■wr i te-cmem 

ur t te-cmem-snd-par t ty 

read-cmem 
-ur i te-amem 

read-amem 

read-amem-and-par i ty 

wr i te-bmem 

read-bmem 

read-bmem-and-par i ty 
-wr i te-type-tnap 

wr i te-type-map-and-par i ty 

read-type-map 
-ur i te-gc-map 
-wr i te-gc-map-and-par i ty 
-read-gc-map 
-wr i te-cpc 

read-cpc 

wr i te-npc 

read-npc 

ur i te-byte-r 

read-byte-r 

wr i te-byte-5 
-read-byte-s 

wr i te- stack-pointer 

read-stack-pointer 

wr i te-frame-poi nter 

read- f rame-po i n ter 
-ur i te-xbas 

read-xDas 

read-obus 
-wr i te-md 

read-md 

wr i te-vma 

read-vma 

ur i te-pc 
-read-pc 
-read-asn 

read-crocks 

reset-lbus 

reset-3B33 
-read- I bus-board- id 

read-fep-bo3rd-id 

r ead- f ep-padd I e- i d 

read-opc 
-read-ctos 

wr i te-cur-task 
-read-cur-task . 
-wr t te-cstk 

stk-and-par I ty ur I te- 

-read-cstk 

ur ) te-csp 

read-csp 
-ur i te-comm-var 

read-comrn-var 

start-machine 
-step-machine 

stop-machine 



read-words 


T) 


goto 


T) 


t ions above thr s 1 ine. 




wr i te-!bus 


NIL) 


ur i te- 1 bus-and-ecc 


NIL) 


read- 1 bus 


NIL) 


read- I bus-and-ecc 


NIL) 


wr i te-Ibus-biock 


NIL) 


read- 1 bus-block 


NIL) 


wr i te-f ixnums 


NIL) 


read-f ixnums 


NIL) 


wr i te-cmem-wd 


NIL) 


wri te-uir 


NIL) 


read-uir 


NIL) 


wri te-cmem 


NIL) 


ur i te-cmem-and-par i ty 


NIL) 


read-cmem 


NIL) 


wri te-amem 


NIL) 


read-amem 


NIL) 


read-amem-and-par i ty 


NIL) 


wri te-bmem 


NIL) 


read-bmem 


NIL) 


read-bmem-and-pari tu 


NIL) 


ur i te-type-map 


NIL) 


wri te-type-map-and-par ity 


NIL) 


read-type-map 


NIL) 


wri te-gc-map 


NIL) 


ur i te-gc-map-and-par i ty 


NIL) 


rcad-Qc-map 


NIL) 


wrt te-cpc 


NIL) 


read-cpc 


NIL) 


wri te-npc 


NIL) 


read-npc 


NIL) 


wri te-byte-r 


NIL) 


read-by te-r 


NIL) 


wri te-byte-s 


NIL) 


read-byte-s 


NIL) 


wri te-stack-po inter 


NIL) 


read-stack-pointer 


NIL) 


wri te-frame-poi nter 


NIL) 


read-frame-pointer 


NIL) 


wr i te-xbas 


NIL) 


read-xbas 


NIL) 


read-obus 


NIL) 


wri te-md 


NIL) 


read-md 


NIL) 


wr i te-vma 


NIL) 


read-vma 


NIL) 


wri te-pc 


NIL) 


read-pc 


NIL) 


read-asn 


NIL) 


read-crocks 


NIL) 


reset-tbus 


NIL) 


reset-36B3 


NIL) 


read- 1 bus-board- id 


NIL) 


read-f ep-board- i d 


NIL) 


read-fep-paddle-id 


NIL) 


read-opc 


NIL) 


read-ctos 


NIL) 


ur i te-cur-task 


NIL) 


read-cur-tack 


NIL) 


ur i te-cstk 


NIL) 


-cstk-and-por i ty NIL) 




read-cstk 


NIL) 


wri te-cep 


NIL) 


read-ccp 


NIL) 


ur i te-comm-var 


NIL) 


read-ccmm-var 


NIL) 


start-machine 


NIL) 


step-machine 


NIL) 


stop-machine 


NIL) 
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(373 procesE-restore-state 
(374 process-discard-state 
(4CQ process-kludge-status 
(401 prccess-send-kludge-tninl-bytes 
(482 process-send-k ludge-mini-words 
(4P3 process-send-k i udge-m i n i - i ongs 
(484 process-send-k ludge-char 
(4C5 process-k I udge-rece i ve-chars 
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restore-state 

di scard-state 

kludge-status 

send-k I udge-m i n i -bytes 

8end-kludge-m t ni -words 

«end-k I udge-m in i - 1 ongs 

send-k ludge-char 

k t udge-rece i ve-chars 



fJIL) 
NIL) 
NIL) 
NIL) 
NIL) 
NIL) 
NIL) 
NIL))} 



(defun crack-fep-command-args (name args) 

(let* ((length (+ 2 (loop for (arg type) tn args 

sum (selectq type (byte 1) (word 2) (addr 3) (long 4))))) 
(array (make-array length * : type 'art-Sb *:area working-storage-area)) 
(opcode (f ep-op-nur.ber-from-nanie name) ) ) 
(if (null opccde) (f error "FEP command -^A Js not defined." name)) 
(loop for (arg type) in M (.opcode word) . ,3rgs) 
u) th code -nil 

for index ■ then (+ index this-len) 

tcr this-len « (selectq type (byte 1) (word 2) (addr 3) (long 4)) 
do (if (number p arg) 

( looo repeat this-len 

for ppss upfrom tfoQSlQ by #ol0C0 
for i upfrom index 

do (sstf (aref array i) (Idb ppss arg))) 
(push Mlet ((temp ,arg)) 

,t(loop repeat this-len 

for ppss upfrom #00010 by ;?olC30 
for i upfrom index 

collect Msetf (aref array »i) (Idb .ppss tenp)))) 
code) ) 
finally (return opcode length array code)))) 

(defun f ep-cp-nurr.ber-from-name (name) 

(iccD for (n fep-name console-name) in *fcn-to-opcode-mappings* 

if (string-equal (string name) (string console-name)) return n 
finally (f err or "No fep op for -^A" name))) 



(defun f ep-cp-nurrber-from-process-func 
(loco for in fep-nane console-name) 
if (string-equal (string name) 
finally (terror "No fep op for 
(aefconst «sou-bus- locat ions* 
M(3PY-CnEn 100) 

(SPY-SQ-DOARD-ID 115) 
(S^Y-SQ-CTL.llG) 
(SPY-SQ-STATU5 120) 
(5PY-NEXT-CPC 122) 
(SFY-OPC 125) 
(SPv-TASK 124) 
(SPY-CT05-H1GH 12r) 
{SPY-5a-5TATUS2 12E) 
(SPy-nC-CONTROL 140) 
(SPY-nC-ID 140) 
(SPY-nC-EHRCR-STATUS 141) 
(SPY-ECC-SYNDROriE 142) 
(5PY-ECC -ADDRESS 143) 
(SPY-nC-STATUS 144) 
(SPY-NET-SELECT 150) 
(SPY-NET-CONTRCl 151) 



tion (name) 

in *fcn-to-opcode-r.appings« 

(string f ep-name) ) return n 

-'A*' name))) 

; 13. bytes of control-memoru read/write data 

;Ur ites the CflEn UD regi^sters, reads the UIR 

;Read board ID prom (indexed by U AriRA) 

;Urtte SQ control register (2 bytes) 

;Read SQ status (2 bytes) 

jRead NEXT CPC lines (2 bytes) 

;Read micro PC history memory (2 bytes) 

;Read current task number 

;Read bits 14,15 of CTOS 

;nisc status bits 

;Ur i te only 

;ID indexed by low 5 bits cf SPY-nC-CONTROL 

;G-0 inverted syndrome bits, 7 error flag 
;l-0 ADDR<l-0>. 7-2 ACDR<23-1S> 



(SPY-CrtA-HIGH-ADDRS 214) 
(SPV-Dr.A-CONTROLLER 220) 



(FEP-BOARD- ID-CONTROL 341) 
(FEP-SERI AL-Dr!A-AND-CLDC)C-CTL 343) 
(FEP-nrrA-CONTRCL 344) 
{FEF-rr^X-CONTROL 345) 
(FEP-LEU5-C0IJTR0L 350) 
(FEP-PAOOLE-ID-PROr; 240) 
(FEF-BOARD-lD-FROn 300) 
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(npsc 


-es. 


-A 


203) 


(nps:- 


-0 


-3 


201) 


(HPSC- 


-1- 


-A 


204) 


{MPSC 


-1- 


-B 


20S) 



(SPY-LBL'S-CONTROL 2E.0) ;Lbu9 control 

(FEP-5ERIAL-BA!JD-RATE-e 254) 
(rEP-£ERIAL-BA'JD-RATE-l 35G) 

{FEP-HEB-COr.'TRGL 3G0) 
(PEP-Ho3-DATA 2Z2) 
(FEP-HSB-POINTER 2G4) 
(P-PDRT 370))) 

(defun eva I -spy-symbol (symbol) 

(let {{pair (ass 'string-equal symbol *spy-bu3- locat i ons*) ) ) 
i'\i pair (cadr pair) 

iier ror " Fa iled to find a def inition for spy^bus location -^A. " •symbol)))) 
;;; These 3re variables in the fep program that the debugging console program 
;;; may uant to access. 

(defconst *con5ole-conrunic3t ion-var iabies* 
M{*nACHINE-RlirCNlNG* BOOLE) 
{*UPOATE-STATUS* BOOLE) 
(«SAVE-STATE* BOOLE) 
(*READ-5TATEiit BOOLE) 
(*SAVZD-£Q-5TATU5* 5Q-STATUS) 
(<ejIR-?;AVED* OGOLE) 
{*5EQUENGER-SAVED* BOOLE) 
(«IO-nD-SAVED* BOOLE) 
(»£nU-nD-PAIR-SAVED« BOOLE) 
(«vnA-SAVED* ECOLE) 
(*PHTA-ASN-SAVED* BOOLE))) 
;;; 'this put into the coapi ter. 
^+cadr 

(eval-uhen (corrpile eval load) 
coirpiler:(DEFniC sy5:rSEr40-BYTES 730 

(UB-LOG CHEC<SUn-SEED NUMBER-OF-BYTES ART-SB-ARRAY STARTING-IDX) T) 
compi ler: (DEFMIG 8ys:%RECEIVE-BYTES 

731 (UB-LOC CHECKSLin-SEED MLfHSER-OF-BYTES ART-SB-ARRAY 5TARTING-IDX) T)) 

;;; Rotate a IE bit quantity left one bit. {Frequently defined elssuhere.) 

(remprop 'rot-l-lG ' : source-f i le-name) 

(defRiacro rot-1-16 (value) MIet ({val .value)) (dpb val ;;fo0117 (Ish val -15.)))) 

F:>linach>fep>Fep-macros,1isp.9 



:; -*- nod?:LI5P: Package:LIL: BaserS; Louercase: Yes -»- 
;: (c) Copyright 1982» Symbolics, inc. 

This module knows about words containing various bit fields 
Entr ics: 

DEFUORD - define a "data type" and its fields 

BUILD - a macro that allows words to be constructed 

FIELD - a wacro that allows words to be taken apart 

;Options is a list of options, as follows: 

; iCOnnA - put commas between fields (otherwise there are two space-) 

A word description is a list of field descriptions 
A field description is generally: 

(type name args. . . ) 
The fieid name is a string, used on input and output, or a list 

(input-name output-name); output-name may be omitted and no field name is typed out. 
The input-name is used on input and in the BUILD macro. 
The field name may also be (input-name output-name default-value) 
which is sometimes more convenient than specifying the default value 
with a NIL in the possibilities list, and allows the default for input to 
sti I I get typed out. 

:Specif ical ly one of the following; 
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(:3IT name bit-nufnder true-string false-string) 
If either string is NIL or omitted, the bit Is ignored in that state, 
- which is considered to be the default. 

If both strings are omitted, the bit is typed out as 1 or 
(:BYTE name n-bits bits-over value-strings...) 
If there are no value strings, the byte is typed out numerically. 
Otherwise the value strings are for consecutive byte values starting 
with 9. NIL means the default value (nothing is typed out). 
T means to type the corresponding number <no symbol exists.) 
Running off the end of the list of value strings is the same as To 
{:CASE n-bits bits-over clauses...) 
Selects the clause corresponding to the value of the specified byte field 
A clause is a list of field descriptions. 
— Restrictions: no default field values from case clauses In BUILD. 
because it doesn't know which case it is. Also BUILD can't deal with 
name conflicts between fields in different case clauses. 
(rPRINT string) 

Constant string, mainly useful inside of :CASE 
(: ADDRESS segment-variable n-bits bits-over) 
The byte specified, or the whole word if n-bits and bits-over are omitted, 
J 9 printed as an address in the specif ied segment. 
Tr i vial support 

(defun byte (bits bits-over) 

(if (> bits 77J (terror nil "Byte field too wide (maximum of S3, bits)")) 
(+ (Ish bits-over 6) bits)) 

<^+Cadr ;Grati tous incompat ibj I i ty 

(compi ler: add-opt imizer byte opt imize-i f-constant-args) 
(defun opt imize-i f-constant-args (form) 

(if (loop for N in (cd*- form) always (constant-form-p x)) 

(list 'quote (eval form) ) 

form)) 

(retnprop 'constant-f crm-p ' source-f i le-name) ; inhibit warnings... 
(defun constant-'form-p (form) 

(or (numberp form) (stringp form) (eq form t) (eq form nil) 
(and (listp form) (eq (car form) 'quote)))) 
(defmacro defword (type-name options 4r est description) 
•(evat-when (compile load eval) 

(defprop , type-name (.options . ,descpipt ion) word-description))) 

;;; This is the macro that is called by actual LIL code 
(defmacro til-defuords (Arest type-names) 
(pkg-bind ff. (pkg-na«e package) 
(cons 'progn 

(loop for type-name in type-names 

append (let ((n-bits tget-defword-length type-name)) 
type) 
(if (> n-bits 32.) 

•((deftype , type-name (array byte , (// (+7 n-bits) 8.)) 
defaul t-«ode ref) 
(deftype ,(f intern "-A-PTR- type-name) (pointer , type-name) ) ) 
;5 If S 32 bits, then make a union type structure. 
(cond ((< n-bits 8.) (setq type 'byte)) 
((< n-bits 16.) (setq type *word)) 
(t (setq type * long))) 

__ *i^*^"**yP* •^ype-na«8 , type allow-ar i thmetic t)))))))) 

;E.g. (BUILD niCROmSTRXTION CPt: NAF NAF LOO ~ 

; here the CPC field gets NAF. a constant, and the NAF field gets LOG, a variable, 

; A variable is any symbol not a constant. Any list is an expression to be evaluated. 

(defmacro i i l-bui Id (type irest fields) 

(multiple-value-bind (def iora andcaa runtime) (crack-fields type fields) 
(let* (deng (get-def word- length type)) 
(mask (1- (ash i leng))) 
(andra (logxor andcam mask))) 
(setq def (logior iorm (logand andm def))) 
(if (< leng 32.) 

;; If it's one of the ones that fit in a longword 
(loop with val - def 
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for (po9 n\z field) in runtime 

do (sctq val • (dpb .field , (+ (Ish po5 G) siz) .val)) 
final ly (return val)) 
;; if it won't fit in a longuord, then the type is siiipty an array type 
(let ((val '(constant , type 

.•(loop repeat (// (+ leng 7) 8) 

for ppss upfrow ;S?o0010 by MolQBB 
collect (Idb ppes def))))) 
(when Punt ine 

(setq val MIet ((temp .val)) 

.•(loop for (pos siz field) in runtrne 

collect *(ineert-uwopd-f ield .pos .eiz temp .field)) 
temp)}) 
val))))) 

(defun tiaybe-suap-bytes (ud) 
(if «bd I c» wd 

(logior (logand 77682377 (ash ud -8.)) 

(logand 37788177408 (ash wd 8))))) 

(defmacro lil-change (type item irest fields) 

(mul tiple-vaiue-bind (def iom andcam runtiae) (crack-fields type fields) 
(ignore def) 

(let* {(leng (get-defword-length type)) 
(mask (1- (ash 1 leng))) 
(andii (logxor andcam mask))) 
(setq iorm (maybe-swap-bytes iorni) 

andffl (naybe-suap-bytes andm)) 
(if (> leng 32.) (f error nil "I can't change -^As," type)) 
(setq item (cond ((and (zerop iorm) (zerop andcatn)) item) 
((zerop iorm) ' (LOG AND .ANDtt .ITEfl)) 
((zerop andcam) '(LOGIOR .IORM JTEM)) 
(t • (LOGIOR .IORM (LOGAND .ANOn .ITEH))))) 
( loop ui th val «* i tem 

for (pos siz field) in runtime 

do (setq va! * (dpb .field ,(+ (Ish pos B) siz) ^vaD) 

finally (return val))))) 

(defmacro lil-alter (type-name word 4rest f-v-pairs &aux dcsci options) 

(if (neq type-name 'microinstruction) (f error nil "not till size unresolved arrays,..")) 
(multiple-value (options desci) (get-defuord-descr iption type-name)) 
• (progn 

.•(loop for (name val) on f-v-pairs by 'cddr 

for desc ■ ior (f ind-desc-for-named-f ield name descl) 

(ferror nil "-^^S undefined field name in a -^S" name type-name)) 
for nval - (selectq (car desc) 

(:bit (or (byte-value- lookup val (cdddr desc) 1) val ;?? suck 

(ferror nil "--S not a defined field value." val))) 
(:byte (or (byte-value- lookup vat (cddddr desc)) val ;?? suck 

(ferror nil "^S not a defined field value." val))) 
(OTHERUISE (FERROR NIL "Can't handle this descriptor: --S" DESC))) 
collect (multiple-value-bind (p s) (get-f ield-p-s type-name name) 
*(insert-uuord-f ie ld .p .s .word .nval))))) 
;Routine to "crack" the fields of a'word. 
;Returns the following values. 
First the ^'defaults" as a bignum 
Second, a mask of the bits forced true. 
Third, a mask of the bits forced off 

A list of (pos siz val) triplets for field values that aren't known at compile time, 
(defun crack-fields (type-name fields 

daux descl options (iorm 8) (andcam 0) (default 8) runtime tem) 
(multiple-value (options descl) (get-dcfword-descript ion type-name)) 
;First pass— fill in the defaults for this type of word 
(do! ist (desc descl) 
(selectq (car desc) 

(:bit (if (or (and (listp (cadr desc)) (eq (caddr (cadr desc)) 1)) 

(and (> (length desc) 3) sif default value of bit is 1 

. (nul I (cadddr desc)))) 
(setq default (logior (ash 1 (caddr desc)) default)))) 
(:byte (if (and (listp (cadr desc)) (cddadr desc)) 
(setq default (dpb (caddr (cadr desc)) 

(byte (caddr desc) (cadddr desc)) default)) 
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(loop for val in (cdr (cddddp desc)) 
as n upfpow 1 
Mhen (nul I vat ) 

return (setq default (dpb n (byte (caddr desc) (cadddr desc)) 

default))))) 
(:ca5e ))) ;Can''t be handled reasonably 
;5econd pass — collect all the constant fields Into UORO 
(loop for (name val) on fields by *cddr 

as desc » (f ind*desc-for-named-f ield name desc I) 
uhen (nul I desc) 

do (f error nil "^S undefined field name in a ^5" name type-name) 
else do 

(selectq (car desc) 

(:bit (if (and (atom val) (setq tern (byte-value- lookup val (cdddr desc) 1))) 
(if (zerop tern) 

(setq andcam (logior andcam (ash 1 (caddr desc)))) 
(setq ions (logior iorm (ash 1 (caddr desc))))) 
(push •(, (caddr desc) 1 ,val} runtime))) 
(:byte (let* ((siz (caddr desc)) 
(pos (cadddr desc)) 
(msk (1- (ash 1 siz)))) 
(cond ((and (atom val) (setq tern (byte-vaiue- lookup val (cddddr desc)))) 
(setq iorm (logior iorm (ash tern pos))) 
(setq andcam (logior andcam (ash (logxor ten msk) pos)))) 
(t (push Mtpos ,8iz ,van runtime))))) 
(otherwise (f error nil "Can't handle this descriptor: *S" desc)))) 

(values default iorm andcam r unt ime) ) 

(dcfun get-f ield-p-s (type-name field-name Aaux desci options desc) 
(multiple-value (opt tons desc I) (get-defuord-descr iption type-name)) 
(or .(setq desc (find-desc-for-named- field fietd-name descD) 

(f error nil "-^S is not a field of a •'S" field-name type-name)) 
(selectq (car desc) 

(:bit (values (caddr desc) 1)) 

(:byte (values (cadddr desc) (caddr desc))) 

(otherwise (ferror nil "Can't handle this descriptor: -^S" desc)))) 

(defun f ind-desc-for-named-f ield (name descI) 
(prog f ind-desc-for-named-f ield 
(dot ist (desc descI) 

(cond ( (eq (car desc) ':ca8e) 

(delist (desc I (cdddr desc)) 

(if (setq desc (f ind-desc-for-named-f ield name descD) 
(return-from f ind-desc-for-named-f ield desc)))) 
((eq (car desc) •:print)) 

((string-equal (if (listp (cadr desc)) (caadr desc) (cadr desc)) name) 
(return-from f ind-desc-for-named-f ield desc)))))) 

(defun byte-value- lookup (val possibi I i t ies ^optional backwards) 
(cond ((or (numberp val) (listp val)) val) 

((loop for poss in possibilities as n upfrom 

uhen (if (or (eq poss nil) (eq poss t)) (eq val poss) 
(string-equal val poss)) 
return (if backwards (- backwards n) n))) 
(t ni I))) 

;;; This returns the length of a DEFUORD defined word 
(defun ge t -de f word- length (word-name) 

(buI t tple-value-bind (ignore descI) (get-defuord-descr iption word-name) 

(if (null descI) (ferror "*-*-A has not been defined by DEFUORD." word-name)) 
(loop for field in (cdr desc I) 

maximize (selectq (car field) 

(:bi t (1+ (third field))) 

(:byte (+ (third field) (fourth field))) 

(otherwise 0))))) 

;;; This gets the defword description given the word name 
(deff get-defuord-descr iptf on 'u5er:get-defword-descr iption) 
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(dtfconst «8y8dfl« (ui th-open-f i It (stpean "F:>Lnach>sgsdfl. I isp**) 
(loop with eof - (neons nil) 

for form - (read stream eof) 
unti I (eq form eof) 
col tect forn))) 

(defconst «sysdef» f«? th-open-f i le (stream "F:>Lriach>Sysdef . I isp") 
(loop with eof « (neons nil) 

for forw ■ (read stream eof) 
unt I I (eq form eof) 
col iect form))) 

(defmacro def ine-sysdfl-atomaacros (&body forns) 
* (ppogn 'compi )• 

.•(loop for (area . Iocs) in forms 

append (loop for name in Iocs 

for tys-name - (if (atom name) name (car name)) 
for lil-name - (if (atom name) name (cadr name)) 
collect Mdefatommacro ,lil-name 

\ (sysdfl-symeval area sys-name)))))) 

(defun sysdfl-symeval (area sym-name) 

(loop for (type a-name . Iocs) in «sysdfl« 

do (if (and (eq type 'def tne-magic-Iocat ions) 
(eq (car a-name) area)) 
(let ((offset (getl a-name ' (a-memory-address virtual-address))) 
(addr (loop for loc in Iocs 
for i upfrom 

do (if (eq sym-name (if (atom loc) loc (cadr loc))) 
(return i))))) 
(if (and offset addr) 

(return (+ addr (cadr offset)))))) 
finally (f error "Couldn't find value in sysdfl for -^.^ sum-name))) 

(defmacro def ine-sysconstant (&body names) 
* (progn 'compi le 

,«(ioop for name in names 

for sys-name • (if (atom name) name (car name)) 

for Itl-name • (if (atom name) name (cadr name)) 

collect Mdefatommacro ,lil-name * , (sysdef-symeval sys-name) )) ) ) 

(defun eysdef-syneval (name) 
(loop named top 

for (type . body) in »sysdef» 
do (selector type string-equaf 
Cdefsysconstant" 

(if (string-equal name (car body)) (return (cadr body)))) 
("defsysbyte" 

(if (string-equal name (car body)) 

(return (+ (second body) (Ish (third body) 8))))) 
("•defenumerated" 

(let (; (e-name (first body)) 
(fields (second body)) 
(start (or (third body) 0)) 
(increment (or (fourth body) 1))) 
(loop for field in fields 

for i upfrom start by increment 
do (uhen (string-equal field name) 
(return-from top i))))) 
("def storage" ) 

(otherwise (f error "Unknown sysdef field type -^A." type))) 
finally (ferror "No sysdef definition found for -vA." name))) 

;;; Returns a triplet of (word-offset, field size in bits, field offset in bits.) 
(defun sysdef-defstorage-symevat (name) 
( loop named top 

for (type . body) in xsysdef* 
do (when (string-equal type "def storage") 
(loop for fields in (cdr body) 
for word upfrom 8 
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for val - (sysdef-defstopage-symevai-l name uord fields) 
do (if val (return-from top val)))))) 

(defun aysdef-defstorage-symeval-l (name offset fields) 
(if (atom (first fields)) 

(if (string-equal name (first fields)) 

(list offset (second fields) (third fields))) 
(loop for field in fields 

for val " (sysdef-defstorage-aymeval-1 name offset field) 
do (if vai (return valJ)))) 

(defmacro I i f-rcmote-ioad-f ield (name pointer) 
(let* ((osp (sysdef-defstorage-symeval name)) 
(offset (first osp)) 
(si ze (second osp) ) 
(pos (third osp) ) ) 
(if (or (null size) (null pos)) 

* (read-f ixnum-from- Ibus (+ .offset .pointer)) 
MIdb ,(+ size (Ish pos G) ) (read-f ixnum-from- Ibus (+ .offset .pointer) ) ) ) ) ) 

• ;: -*- Package: USER: tlode: LISP; Base: 8 -«- 
;;; (c) Copyright 1952, Symbolics, Inc. 

(DEFVAR *0EFU0RD-ALIST* ()> ;a list of word definitions 

:;; Just add the definition to the alist first removing any previous definition 
(EVAL-UHEN (COnPlLE LOAD EVAL) 
(DEFUN ADD-DEFUORD-DESCRIPTION (FORH) 

*^^'^° *CO™FORn^lDELQ (ASS 'STRING-EQUAL (CAR FORH) «OEFUORD-ALIST») 
«OEFUORD-ALIST»))))) 

(DEFl'N GET-OEFUORD-DESCRIPTION (NAME) 
(DECLARE (RETURN-LIST OPTIONS DESCD) 
(LET ((RESULT (ASS 'STRING-EQUAL NAttE «OEFUORD-ALIST*) J) 

(IF (NULL RESULT) (FERROR "^^-S not defined with DEFUORD" NAHE)) 
(VALUES (CADR RESULT) (CDDR RESULT)))) 

::; Use this to define a new "word". 
(DEFnACRO DEFUORD (NAHE OPTIONS &BODY BODY) 
MEVAL-UHEN (LOAD EVAL) 

(ADD-DEFUORO-DESCRIPTION M.NAHE .OPTIONS ,«BDDY)))) 



Options is a list of options, as follows: 

:COnnA - put commas between fields (other 



wise there are two spaces) 

A word description is a list of field descriptions 
A field description is General I y: 

(tupe name args. - . T 
The field name is a string, used on input and output, or a list 

(input-name output-name); output-name may be omitted and no field name is typed out. 
The input-name is used on input and in the BUILD macro. 
The field name may also be (input-name output-name default-value) 
which is sometimes more convenient than specifying the default value 
with a NIL in the possibilities list, and allows the default for input to 
St i I 1 get typed out. 

Specifically one of the following: 

(:BIT name bit-number true-string false-string) 

If either string is NIL or omitted, the bit is ignored in that state. 

which is considered to be the default. 

If both strings are omitted, the bit is typed out as 1 or 8 
(:BYTZ name n-bits bits-over value-strings. •• ) 

If there are no value strings, the byte is typed out numerically. 

Otherwise the value strings are for consecutive byte values starting 

with 0. NIL means the default value (nothing is typed out). 

T means to type the corresponding number (no symbol exists.) 

Running off the end of the list of value strings is the same as T. 
(:CA£E n-bits bits-over clauses...) 

Selects the clause corresponding to the value of the specified byte field 

A clause is a list of field descriptions. 
— Restrictions: no default field values from case clauses in BUILD, 

because it doesn't know which case it is. Also BUILD can't deal with 
name conflicts between fields in different case clauses. 
(:PRINT string) 

Constant string, mainly useful inside of :CASE 
(:TERPRI) 

Advance to next line 
(: ADDRESS segment-variable n-bits bits-over) 

The byte specified, or the whole word if n-bits and bits-over are omitted, 

is printed as an address in the specified segment. 
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• » ♦ 



FEP Status »tuff 



(DEFUORO FEP-SER-DnA-CONTROL (:COnnA) ^ ^ 

(:BYTE A-DHA 2 8 "Xmit A" "Rev A" "Xmlt B" "Rev B") ;Operation to DHA 

(:BYTE B-DHA 2 2 "Xmit A" -Rev A" "Xtnit B" "Rev B") 

{:BIT RX2-CLK 4 "Rx2 External) ;Channel A of second MPSC 

(:BIT aX2-CLll £ "1x2 External")) 

(DEFUQRD FEP-DHA-nODE (:COnnAl 
(;BYTE CHAN:>IEL 2 8) 

(:BYTE DIRECTION 2 2 "Verify" "Unite" "Read" "Iffegal") 
(rBIT (AUTO-INIT) 4 "Auto tnitialtze") 
(:BIT (COUNT-OOUN) 5 "Decrement") 
l:BYT£ (nODE) 2 6 "Denand" "Single" "Bloek" "Cascade")) 

(DEFUORO FEP-OriA-COnnAWD (rCOnnA) 

(:BIT nEnORY-TO-riEnORY 8 "Enable") 
(:BIT CH-8-A0DRE5S-H0LD 1 "Hold") 
{:B1T CONTROLLER-ENABLE 2 "Disable") 
(:BIT TiniNG 3 "Compressed") 
(:BIT PRIORITY 4 ^'Rotating" "Fixed") 
(:BIT SELECTION 5 "Extended" "Late") 
{:BIT OREO B "Active low" "Active high") 
l:BIT DACK 7 "Active lou" "Active high")) 

(DEFUORO FEP-HSB-CONTROL (rCOnriA) 

(:B1T (SPY-OnA-ENB) 8 "Spy DTIA Enb" "-Spy DTIA Enb") 

(:BIT (URITE-TO-DEV) 1 "Urite to dev" "Read from dev") 

(:BIT (DRIVE-BUSY) 2 "Drive busy") 

(:BIT (INT-ENS) 3 "Int Enb") 

(:BIT (COUNT-UPi 4 "Count up" "Count down") 

(:BIT (BUSY) 5 "Bueu") 

(:BIT {NOT-SPy-OnA-BUSY) 6 NIL "Spy DHA busy") 

(:BIT (DHA-SETUP) 7 "DHA setup")) 

(DEFUORO FEP-LEUS-CONTROL-REV-1 (:COnnA) 

(:BIT (ECC-DIAG) "ECC Diag") 

(:BIT (DOORBELL- 1 NT-ENB) 1 *^DoorbeIt Int Enb") 

(:BIT (SPECIAL -LOAO-nD) 2 "Special Load-MD") 

(:BIT (OEUS-TO-LBUS) 3 "Obus to Lbus") 

(:BIT (TASK-3-REQ) 8 "Task 3 Req") 

(:BIT (DOORBELL) 9 "Doorbell")) 

(DEFUORO FEP-LBUS-CONTROL (rCOnriA) 

(:31T (ECC-DIAG) "ECC Diag") 

(:BIT (DOORBELL- I NT-ENB) 1 ^Doorbell Int Enb") 

(:BIT (USE-UNC-OATA) 2 "Use Uncorrected Data") 

(:BIT (IGN-OOUBLE-ECC) 3 "Ignore Double ECC Error") 

(:BIT {TAS<-3-REQ) 8 "Task 3 Req") 

(:BIT (DOORBELL) 9 "Doorbell") 

(!BIT (NOT-BUSY) 10, NIL "Lbus Buffer Busy") 

{:BIT (SOnE -PAR-ERR) 11. "Lbus Buffer Some Parity Error")) 

(DEFUORD FEP-BOARD-ID-CONTROL-REV-1 (rCOnHA) 
(:BIT (CONTINUITY) "Continuity") 
(:BIT (NOT-IO-REO) 1 NIL "Lbus 10 Req") 
(:BYTE lO-ADR 5 2)) 

(DEFUORD FEP-BOARD- ID-CONTROL (-.COnrtA) 

(:BIT (CONTINUITY) 8 "Continuity") 
(:BIT (NOT-ID-REQ) 1 NIL "Lbus ID Req") 
(:BIT (HALF-SPEED) 7 "Half Speed")) 

(DEFUORD FEP-PROC-CONTROL (tCOnriA) 

{:BIT iPOUER-RESET) "Lbus Power Reset") 

(:BIT (LBU5-RESET) 1 "Lbus Reset") 

t:BIT (NOT-CLEAR-ERRORS) 2 NIL "Clear Errors") 

(:BIT (N0T-INT-EN3) 3 NIL "FEP Int Enable") 

(:BIT (^CEPT-ALIVE) 4 "Kept AMve") 

(:BIT (N0T-PCUER-RE=:ET-RcA09ACK) S NIL "Lbus Power Reset (on bus)") 

(:BIT (NOT-LBUS-RESET-READBACO 6 NIL "Lbus Reset (on bus)") 

(:BIT (RAn-PARIlY-ERROR) 7 "FEP Ram Par £rr")) 

: Control register bits CSPV-SQ-CTL) 

(DEFUORO SQ-CTL (:COnnA) , , « ,, 

(:BIT (RUN) "Run" "-flun") 

(•RTT (CTPP) 1 "Step ) 

'B T ENA^LE-DP) 2 "Enable-DP" "Disabte-OP") ..... 

•B T (ENABLE-SQ) 3 "Enabte-SQ" "Di sable-SQ") ;This bit is inverted in the hardware 

('BIT (ENABLE-CnEH) 4 "Enable-Cmem" "Disable-Cmem") 

(:BIT (CnEn-URITE) 5 "Cmem-Ur i te") 

(:BIT (ENABLE-TRAP) 6 "Enabte-Trag ) 

(iBIT (ENABLE-ERRHALT) 7 "Enable-trrhal t ) 

(:BIT (ENA3LE-TA50 8 "Enable-Task") 

l;Etf(^Nl8^^lS^J'l3:°^in^bl2V-Up?''-^!U..e.RAn.UP")) 
; Status bits (SPY-SQ-STATUS) 
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(DcFUGRD SQ-STATUS (iCOnHA) 



BIT (SPARE-LOST) "Spare-errop-bl t?") 

BIT (GC-nAP-LOST) 1 •'GC-riap-parl ty-error**) 

BIT (TYFE-nAP-LOST) 2 "Type-map-par i ty-error") 

BIT (PAGE-TAG-LOST) 3 "Paae-Tag-par t tu-error") 

BIT (AriEn-LOST) 4 "A-memory-par i ty-error") 

BIT (BnEn-LOST) 5 "B-memoru-par i ty-error") 

BIT (nC-LOST) 6 **riC-error (map, i f u, or main wem)'*) 

BIT (AU-L03T) 7 "AU-error") 

BIT (HALTED) 8 -nicrocode-ha! ted") 

BIT (CTOSl-LOST) 9 "CTOS- lou-pari ty-error") 

BIT (CT052-L0ST) 10. "CTOS-high-par i ty-error") 

BIT (T5ICn-L05T) 11, "TasK-state-memory-par i ty-error") 

BIT (UIR-PAR-EVEN) 12. "Control-memory-par I ty-error") 

BIT (CTOS-CAHE-FROn-IFU) 13. "CTOS-came-from-IFU") 

BIT (TSK-STOP) 14. "TS<-STOP (sequencer stopped)") ;Basical ly ERRHALT or -RUN 

BIT (-ERRHALT) 15. NIL "Errhal t-Sync") ;rev.3 only 

More status bits (SPY-5Q-STATUS2) 

BIT (NOT-nC-UAIT) IS. NIL "HC Wait") 

BIT (TASK-SUITCH) 19. "Task Switch")) 



:Hicroin8truction definition 

;For nou ue don't try to do anything fancy uith field overlapping* just use 
; the bit names in the prints 

;Uant to exploit conditionals and subroutines later 
(DEFUORO n I CRO INSTRUCT I ON 
(:BYTE APWA 12. 0) 

(:BYTE AHRA-SEL 2 12. NIL "Lbus addr" "Base+Of f set" "Base//ne«ory//nC//Bus device") 
(:BIT (STKP-COUNT) 15. "Count STKP") ;a clear case for .ore hafr in FORflAT... 
(:BYTE AHUA 12. IG.) 
(:BYTE (AHUA-SEL AHUA-SEL 31 2. 2S. NIL "Base+Of fset" "Same as read" 

*ne«ory//nC//Bus dev I cc//no th i ng" ) 
(:BYTE BrtRA 8 32. ) 
(:BYTE (BnUA BHUA 17) 4 48.) 

i:BIT BHEn-FROn-XBUS 44. "Bmemi-Xbus" "Bmem^^lbus") 
i:TERPRI) 
{:BYTE rcn 3 45. NIL "nicrodevice" "Read" "Urite" 

■Reserve" "Load VttA" "Block Read" "Block Ur ite") 
(iBYTE SPEC 5 48. "Load R" "Load S" "Load STKP" "Load FRHP" 

"Load XBAS" "Load DP Ctl" "Write TYPE//GC «e«" "Clear Stack Offset" 
"Arithmetic Trap Enable" "Trap if Type Cond" 

"Trap if Type Cond or Bbus not Fixnum" "ttultiply uith Type Check" 
"Magic Crocks^ "ALUS Sign Hack" "Crocks to Ybus^ 'riultiply^ 
NIL "Addr From Abus" "Inhibit Page Tags" "DHA" 

"Use PHTA" "Check Urtte Access* T "IFU Control" 
•Arithmetic Trap Enable uith Dispatch" "Halt" "NPC Hagic" 

"Auaken Task" 
"Urite Task" "Disable Tasking" T T) 
(:BYTE HAGIC 4 53.) 
(:BYTE COND 5 57. "Cdrii0" -Cdr,-1" •Cdr02" •Cdp.-3" 

■Tupe Cond" "Bbus not Fixnum" ■ALUB<0>" "YBUS<31>" 
"-fit Condemned Temp" "-GC This Stack" "-GC Other Stack" 

"ALU<27-0>«0- 
"ALU<31-0>.-0" "ALU<33-0>t0" "-Carru<28>" "-Carry<22>" 
"ALU<31>" "Sequence Break" "Trace Flag 1" "Trace Flag 2" 
"-Lbus Dev Cond" "MC Cond" T T T T "-CTOS came from IFU" T 

(:BYTE COND-FUNC 2 B2. NIL "Skip if false" "Trap if true" "Trap if false") 
{:TERPRI) 

(:BYTE ALU 4 S4. ; For now leave out the weird ones 

"Xbus" "AluB" "X+1" "X-r "X+Y" "X-Y" "X+Y+1" "X-Y-l" "AND" "lOR" "XOR") 
{:BYTE BYTE-FUNC 2 68. NIL "naqlctf Kludges" "R-© S-COND" "General") 
(:BYTE XYBUS-SEL 1 14. "A^X B-?" "A-^Y B^X") 
(:BIT OBUS-LTYPE 7B. NIL Tlagictf") 
(:BYTE OBUS-HTYPE 3 73. "Abus" "Bbus" "Bbus<5-4>" T 

"Const 0" "Const 1" "Const 2" "Const 3") 
{-.BYTE OBUS-CDR 3 70. "Abus" "Bbus" "Bbus<7-6>" j ^ *-° » '^ ' 

"Const 0" "Const 1" "Const 2" "Const 3") 
(:BYTE TYPE-nAP-SEL 6 9B. NIL) 
(:BYTE AU-OP S 102. NIL) 
(:TERPRI) 

(:BYTE SEQ 2 30. NIL "PushJ" "Dismiss" "Popi") 
(:BYTE CPC 2 77. "NAF" "CTIJS" "NPC" T) 
(:BYTE (NPC NPC 1) 1 79. "Dispatch" "Next CPC+1") 
(:BYTE NAF 14. 80.) 

(:BYTE (SPEED SPEED 3) 2 94.) ;default to slowest speed 
(:BIT SPARE 110. SPARE-BIT-110) ^ 

(:BIT PARITY 111. PARITY)) 

(DEFUORD C-riEn-ADDRESS 

(:ADORESS LCONS:»C-nEn.SEGnENT») ) 

(DEFUORD OPC -HI STORY 

(:BiT (TAS<-5UITCH) 15. "Task-Switch" NIL) 
(:EIT (NOT-NOP) 14. NIL "Nop'*) 
(rADDRESS LCONS:«C-nEn-SEGnENT« 14. 0)) 



4,887,235 
769 770 

;f40TE NOTE NOTE NOTE NOTE NOTE r> k, ^ , - 

;Bif8 8,3 «re complemented in the rev-1, pev-lA, rev-2 hardware 

tBits 0.1.3 are comptemented in the rev-5 hardware ^ ^ * i, 

(DEFU0R6 nC-COrnROL (:COnnA) ;The default value needs to be zero for some code to work 

*^ "*^"(:BIT ECC-DRIV^^^ 8 -Disable HC to LBUS<42:3B>" NIL) ^ 

{:BIT (ECC-CORRECT-DI SABLE) 1 "Disable memoru error correction NIL) 

(:BIT (0BU3-T0-LBUS) 2 "Force Obus onto Lbus' N L 

(:BIT (ERROR-RESET) 3 "Clear error registers NIL) 
BIT (flAP-A-DISABLE) 4 "Map A Disable^ N L 

(:BIT (nAP-B-DlSABLE) 5 "ttap B Disable" NIL) -n- wtm 

(:aiT (SPECIAL-LOAD-PtD) 6 "Force LBUS wr*te data into flD" NIL) 

;bit 7 spare 
„) ~ 

(DEFUORO ttC-ERROR-STATUS (:COmA) ^ 

l:BIT (DOUBLE -BIT-ERROR) 8 "Double bit error" NIL) 

(:BIT (riAP-A-PARITy-ERROR) I "ttap A parity error N L) 

( B T (nAP-B-PARlTY-ERRDR) 2 "Hap B parity error" NIL) 

(IbIT (DDUBLE-nAP-H IT) 3 "H it m both sap A and «3p B" NIL)) 

(DEFUORD nC -STATUS (:COnnA) 

(:BIT ADDR-IN-AnEn 8)^ _ 
(iBYTE VflA-nO-OFFSET 2 1) 
(:BIT vnA-FOR-nD-8 3) 
(JlT IFU-EHPTY 4))_ 

(DEFUORO NET-STATUS (:COmA) 

}:JI^S^3!rCv4nSblE) 4./CPy receive enable" "CPU transmit enable") 

liiI?'(BJlS^^F^^l!iSBLio?H. "BlcLff enabled;) 

;B T (BUFFER-OVERFLOU) 8; "Bu*^?*:.0Y«: °"^ 
1 mT NFT-COLLISION) 3. "Net collision ) 
iWl PREAnBLE-ERR^^ 18. "Preamble error") 

•J T ALIGNHENT^RRO^ "Alignment error") 
('rit rRC-ERROR) 12. "CRC error') 

;B T P<T.R£CE1VED) 13, -Packet received") 

•BIT CABLE-BUSY) 14. "Cable busy") 

'fi T (XMT-REQUEST) 15- "Transmit request") 
^B T RECEIVE-CLO IB. "Recei ve clock^ 

;B T RECE VE-DATA> 17- "Receive data") 
B T (DATA-VALID) 18. "Data vaitd") ^ ^ _. 
i'Bll COLLISION-DETECT) 19. "Col i tsion detect") 

:B T (TEST-CABLE-BUSY) 28. "Cable busy(test)-) 

iBT TRANSriIT-CL<) 21. NIL "Transmit cock") 

:BIT (TRANSniT-DATA) 22. 'Transmit data ) 
(:BIT (CRC-DATA 23. "CRC data") 

•B T (^€T-START) 24. NIL "Net start") 

••B T UA T-FOR-PKT) 25. NIL "Uait for packet") ^ 

;B T PREAHBLE-B) 26. NIL ;Preamb e 8 T 

(:BIT (PREAflBLE-l) 27. NIL "Preamble 1 ) 

{:ElT^^T?BETl!*G-fRANSf^ "P??*^** being transmitted") 

liBlT (PREAHBLE-DATA) 31. "Preamble data") 

) 

(DEFUORD NET-OIAG (iCOnriA) 

(:BIT (RECEIVE-CLOC<) 16. "RCV C ock") 

(:BIT <RECEIVE-OATA) 17. "Data 1 ) 

(:BIT (DATA-VALID) 18. "Data Valid ) 

(:BIT (COLLISION) 19. ^Collision ) 

(:BIT (BUSY) 28,^"Busu") ri«rwM 

(:BIT (TRANSniT-CLOOCJ 21. NIL XHT Clock ) 

) 

(DEFUORD VD-DIAG (jCOmA) 

{iiUE^tl^Li?-" 2^?!' -Poi: -Pu-^^" -NOP- -Nop-) 

(:BIT (ZERO) 13. NIL "Zero" 

(:BIT (INC) 14. "Increment") 

(:BIT (SYNC-DATA) 15. "Sync data")) 

(DEFUORD VD-STATUS (:CgnriA) 

(:BIT (VO-BOU-nODE) 8 "BOU Mode") ^ , ^^ 

(:BIT (VSYNC-TASK-ENABLE) 1 "VSync Task enable") 

(:BIT (VSEQ-ENABLE) 2 "Sequencer enable ) 

(:B1T (VSEQ-RUN) 3 "Sequencer run") 

(:BIT (VUAKEUP) 6 "Uakeup") 

(:BIT (VSEQ-STEP) 7 "Single step") 

(:BIT (VSYNC) 8. "Vertical SyncM 

(:BIT (HSYNC) 9. "Horizontal Sync") 

(:BIT (BLANK) 18. "Blanking") 

(:BIT (AUOIO-CYaE)^ll. "Audio cycle") 

(:BIT (DISPLAY-CYCLE) 12. rCt«P fay cycle ) 

(:BIT (REFRESH-CYCLE) 13. NIL ^Refresh cycle") 

(:B1T (LPTR-CYCLE) 14. NIL "Line pointer cucie ) 

(:B1T (FRX-CYCLE) 15. NIL "Processor cycle") 

(•BYTE "tunc in2tT"r27^ "Icero" "Cond JSB PL" "Jump HAP" "Cond jump PL" _ , 
^•BYTE .Sync mst^ ^ ^/^„ ^ ^^ ^^^pj_. .^^^^ jump VEC" "Cond Jump R//PL"^ 

•Reoeat Loop; CTRiiB- "Repeat PL, CTR08- "Cond RET- "Cond. jump PL « Pop" 
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■Load CTR" *Teat end loop" "Continue" "Three wag branch ) 
(:BIT (RLD-L) 31. NIL "Sync CC") 
I 
;;; Register for«ats 

(DEFUORD DlSIC-COmAWD (iCOmA) 
hBYTE BUS 11. 8) ^^ 
{:BIT (DBU5-IN) 11. 'Bus from disk") 



(:BIT IU(NIT.TAG) 12. "Unit tag") 
(:BIT (CYL-TAC) 13. "Cul tag") 
(:BIT (HEAD-TAG) 14. "Head tag") 



(:BIT (HEAD-TAG) 14. "Head tag") 

(:BIT (CONTRGL-TAG) 15. "Control tag") 

(:BYTE UNIT 4 IG.) 

(:BIT (TAG-41 10. "Fuiiteu tag-4") 

(:BIT (TAG-5) 19. "Fujitsu tag-S") 

(:BYTE CnO 4 28. "Read-36" "Read-32" ■Read-8'* 3 

4 5 "Awai t-sector" "Error-correct" 

■Urite-3S" 'Ur i te-32" 12 13 

"Read//compare-3S" "Read//compare-32" "Ur ite-al I" 17) 
(:B!T (START) 24. "Start") 
(:BYT£ TASK 4 25.) 

(:BIT (FEP-LSING-DISK) 29. "FEP using disk") 
(:BIT (3B-BIT-nCDE) 33. "3S-bi t-Bode' ■32-bi t-BOde") 
(:BIT (SPARE) 31. "spare-bi t-31")} 

(DEFUORD DISK-ECC (xCOmA) 

(:BYTE ERROR-PATTERN 11. 0) 
(:BYTE BIT-NUnSER 5 11.)) 

(DEFUORD DISK-DIAG (:COnnA) 
(:BIT READ-CL< 0) 
(:BIT SERVO-CLK 1) 
(:BIT READ-DATA 2) 
(:BIT INDEX 3) 
(:BIT SECTOR 4)) 

(DEFUORD DISK-RPS (:CDmA> 

(:BYTE UNIT-e-POS 4 0) 
(:BYTE UNIT-1-POS 4 4) 
(:BYTE UN1T-2-P0S 4 18) 
(:BYTE UNIT-3-P0S 4 14)) 

(DEFUORD DISK -STATUS (:C0nnA) 

(:BIT (READY) "Ready" "Not ready") 

(:BIT (ON-CYLINOER) 1 "On cylinder" "Off cylinder") 

(:BIT (SEEK-ERROR) 2 "Seek error") 

(:BIT (FAULT) 3 "Fault") 

(:BIT (READ-ONLY) 4 "Read-only") 

(:BIT (ADDRESS-MARK) 5 "Address-Bark") 

(:BIT INDEX 6) 

(:BIT SECTOR 7) 

(:BIT READ-CLK 8) 

(:BIT SERVO-CLK 9) 

(:BIT READ-DATA 10.) 

(:BIT (PADDLE-DISABLE) 11. "Paddle disable" "Paddle enable") 

(:BIT (DISK-ERROR) 12. "Disk error") 

(:BIT (SELECT-ERROR) 13. "Select error") 

(:BIT (OVERRUN) 14. "Overrun") 

(:BIT (ECCZERO) 15. "ECC-0" -ECC.-0") 

(!BIT READ-COnPARE IS.) 

(:BIT END-FLAG 17.) 

(:BIT BUF-BUSY 18.) 

(!BIT UAKEUP 19.) 

(:BIT URITE-DATA 20.) 

(:BIT (NOT-SET-DONE NIL 0) 21. NIL "Set done") 

(:BYTE (U-FUNC) 2 22. NIL "Stop if ECC-0" "Err if start block" "Func set done") 

(:BIT (NOT-IDLE) 24. "STM not idle" "STM Idle") 

(:BIT NEXT-STATE-0 25.) 

(:B1T (ADVANCE-STATE) 2B. "Advance state") 

(:BYTE U-STATE 5 27.)) 

(DEFUORD lOB-PADDLE-ENB (:COmA) 
(:BIT ID-ENA3LE 0) 
(:BIT DISK-DISABLE 1) 
(:BIT NET-DISABLE 2) 
(:BIT POUER-QK 3)) 

(DEFUORD DISK-UCDDE (:COnnA) ;Bottoa 2 bytes registered, top byte not' 

(:BYTE U-STATE 5 0) 

(iBIT CLOCK -SEL 5 '"Read" "Servo") 

(:BIT (READ-GATE) S "Read gate") 

(:B1T (URITE-GATE) 7 "Urite gate") 

(:BYTE U-UAIT-5EL 2 10 "3 bits" "End word" "Read data-1" "Start block") 

(:CASE 1 7 iCondit tonal on urite gate 

((:BYTE U-DATA-SEL 2 12 *ECC feedback" "Read data//ECC" 2 "Clear ECC")) 
((:BYTE U-DATA-SEL 2 12 "Urite 1" 1 "Urite data" "Urite ECC"))) 

(sBIT (DATA-FIELD) 14 "Data field") 

(:BIT (UAKEUP) lb "Uakeup") 

(:BYTE (U-FUfiC) 2 IS NIL "Stop if ECC-0" "Err if start block" "Set done") 
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(:BYTE WORD-LENGTH 4 28 " '" 

"izs" "izA- n84- "lae- -95- "92- -72" "gs- 

"64- -60" "49" -36" -32" "28- "I" -4^) 
(:BYTE NEXT-STATE-CTL 2 24 8 1 -Skip if end* 3)) 
; an d 2 unused spare bits 

$;: -*- Mode: LIL; Package: LIL; Base; 8; Louercaee: Yes -*- 
(sct-default-psect code) 



Fi>LHach>Fep>dcfs, M 1.7 



(dcftype along long al low-ar i thmet ic t) 

tdeftype boole-ptr {pointer boole)) 
(deftype byte-ptp (pointer byte)) 
(deftype word-ptr (pointer uord) ) 
(deftype long-ptr (pointer long}) 
(deftype slong-ptr (pointer slong)) 
(deftype address-pointer (pointer address)) 

(deftype «boolc-array (array boole «) volatile t) 
(deftype «byte-array (array byte «) volatile t) 
(deftype *word-array (array uord ») volatile t) 
(deftype «long-array (array long ») volatile t) 
(deftype «slong-array (array slong ») volatile t) 
(deftype *address-array (array address ») volatile t) 

(deftype *boo(e-array-ptr (pointer *boole-array)) 
(deftype «byte-array-ptr (pointer «byte-array) ) 
(deftype *word-array-ptr (pointer «uord-array) ) 
(deftype »long-array-ptr (pointer «Iong-array) ) 
(deftype «slong-array-ptr (pointer tslong-array) ) 
(deftype *address-array-ptr (pointer »addrcss-array)) 

#+8DLC (progn (def«acro ->s!ong ( long) '(coerce slong (rotr Jong 15.))) 

«Dnir / (defmacro <-8long (along) * (coerce long (rotr .slong IS.)))) 

ff-BULL (progn (defmacro ->siong ( long) * (coerce slong (rot-16-32 Jong))) 

(defmacro <-8long (along) • (coerce long (rot-15-32 .along))) 
(defmacro rot-16-32 (num) 

*(+ (rotr (logand (long (rotr (word .num) 8 J) 177777) 15 J 

(logand (long (rotr (word (rotr ,num 15J) 8J) 177777)))) 

(defmacro defvar (name type ^optional (init init-p)) 
; (unless tnit-p 

J (warn --^Variable ^S not inited. You may lose with parity problems." name)) 
(tf (or (symbolp type) 

(and (listp type) (eq (first type) 'array))) 
Mdefglobal .name .type psect data .adf init Minit .init))) 
(f err or "Defvar of *A has garbage type." name))) 

(defcacro defconst (name type &opt tonal init) 

(if (not (symbolp type)) (ferror -Defconst of -^A has garbage type." name) 
(if (null mit) (ferror "Defconst of -A not given an initiai value") 
Mdefglobal .name .type psect code init .init)))) 

(defmacro defvar&ini tfun (name args &body vara) 
(loop for (var type init) on vara by 'cdddr 
unless (nul I type) 

collect '(defvar .var .type .init) into defvars 
collect '(setq .var .init) into aotqs 
finally (return • (progn .©defvara 

(defun .name .args 
.•setqs))))) 

(deffficcro defvariini tarrayfun (name arga fibody arrays) 
(loop for (array type init) on arrays by 'cdddr 
unless (nul I type) 
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collect '(defvar .array .type ()) into defvars 

collect Mloop for (i word) upfrom 2 below (array-length , array) 

do (aetf (aref , array i) ,tnit)) into loops 
finally (return ' (progn .•defvare 

(defun ,name ,args 

♦ •loops) )) ) ) 

(defnacro def-io (name type) 

Mdefglobal ,naaie , type address , (evat-spy-sym&ot name) psect fcp-io volatile t)) 

(defmacro defatommacros (4rest pairs) 

* (progn .•(loop for (name value) in pairs 

collect * (defatommacro .name .value)))) 

(deftype clock-value long aMow-ar i thmet ic t) 

;;;;;; F:>l«ach>fep>sya tern-supports / 1 1. £7 
• « 

(defmacro cbytes (type string length) 
'(constant .type 

.•(loop for ch being the array-elements of string 

col lect ch) 
.•(foop repeat (- length (string-length string)) 
collect 8))) 

(defmacro ptr-incf (ptr type ^optional (amount D) 

Mptr-incf-dccf ,ptr .type + .amount)) 
(defmacro ptr-decf (ptr type ^optional (amount 1)) 

' (ptr-incf-decf ,ptr .type - .amount)) 
(defmacro ptr-incf-decf (ptr type sign amount) 

Msetq .ptr (coerce .type (.sign (coerce long ,ptr) .amount)))) 

(defmacro ptr-rel (ptr type relative-amount) 

•(coerce .type (+ (coerce long .ptr) .relative-amount))) 

(defmacro boole— (a b) '(if .a .b (not .b))) 
(defmacro boole-i< ia bl *(\f ,a (not .b) .b)) 

(defmacro temporary (kludge real) real kludge) 
(defmacro temporary2 (kludge real) kludge real) 
(defmacro for-safety (&rest forms) '(progn .•forms)) 

(defmacro evenp (n) Mzerop (logand .n 1)}) 
(defmacro oddp (n) Mnot (evenp .n))) 
(defmacro bit-test (a b) *(k (logand ,a ,b) 8)) 
(def I ispmacro when) 
(def I ispmacro unless) 

(def I ispmacro import-defwords lil-defwords) 
(def I ispmacro bui Id lil-build) 
(def I ispmacro change Ml-change) 
(def I ispmacro alter til-aiter) 

(import-defwords sq-cti sq-status «icroinstruct ton 

mc-control mc-status mc-error-status 

f ep-board- i d-contro I f ep-proc-contro 1 

fep- Ibus-control fep-hsb-control 

f ep-ser-dma-contro I f ep-draa-»ode f ep-dma-command) 

(def I ispmacro def ine-sysdfl-atommacros) 

(def I i cpmacro def ine-sysconstant) 

(def I ispmacro remote-load-field I i l-pcmote-load-f ield) 

(defmacro def ine-sysconstants (Arest constants) 

Mprogn .•(loop for constant in constants collect Mdef ine-sysconstant .constant)))) 

;;; These work, but they suck. 
(defmacro make-mask (nbits ^optional offset) 
(if offset Mlshl (1- (IshI 1 .nbits)) .offset) 
Ml- (Ishl 1 .nbits)))) 
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{def macro dpb (val ppss word 4aux pp ss) 
i\J i\ istp ppas) 

(if (cq (car ppss) 'byte) 
(aetq pp (third ppas) 
cs (second ppss)) 
(terror "Bad ppss -•A to idb/dpb" ppss)) 
(setq pp MIshp ,ppss S) 

•s Miogand ,ppss 77))) 
Miogiop (logand ,uord (lognot (tshi (1- (Ish! 1 (word ,8s))) 

(uord ,pp)))) 
(Isht (togand ,vat (1- (Ishi 1 (uord .ss)))) 

(uord ,p p)))) 

(def Macro dpb- i or (val ppss uord &aux pp ss) 
(if (I istp ppss) 

(if (eq (car ppss) 'byte) 
(setq p\? (third ppss) 
ss (second ppss)) 
(f error "Bad ppss -^A to Idb/dpb** ppss)) 
(setq pp Mtshr ,ppss B) 

ss Miogand ,ppss 77))) 
•(logior ,uord (Ish! tlogand ,vai (1- (Ishl 1 (word ,ss)))) 
(uord ,pp)))) 

(def macro Idb (ppss uord &aux pp ss) 
(if (I istp ppss) 

(if (eq (car ppss) *byte) 
(setq pp (third ppss) 
ss (second ppss)) 
(ferror "Bad ppss ^A to Idb/dpb** ppss)) 
(setq pp MIshr .ppss 6) 

ss *( togand ,ppss 77))) 
Miogand (Ishr .uord (uord .pp)) 

(1- (ishi 1 (uord .ss))))) 

(defmacro Idb-test (ppss uord &aux pp ss) 
(if (I istp ppss) 

(if (eq (car ppss) *byte) 
(setq pp (third ppss) 
ss (second ppss) ) 
(ferror "Bad ppss -^A to Idb/dpb" ppss)) 
(setq pp MIshr .ppss S) 

ss Miogand .ppss 77))) 
Mbit-test (Ishl (1- (Ishl 1 ,ss)) ,pp) ,uopd)) 

(defmacro dpb-ior-typed (type value ppss uord) 

M.type (logior (ishl (.type .value) (tshr (uord .ppss) S) ) 
(.type .uord)))) 

(defmacro Idb- typed (type ppss uord) 

M, type-' ( logand (.type (Ishr .uord (Ishr (word .ppss) £))) 

(1- (Ishl (.type 1) (logand (uord .ppss) 77)))))) 

(defmacro idb-test-typed (type ppss uord) 

Mbit-test (;type (Ishl (1- (Ishl 1 (logand (uord ,ppss) 77))) 

(Ishr (uord .ppss) 6))) 
(.type .word))) 

;;; Here just for LHach compatibility 
(defniacro ash (val count) 
(if (not (numberp count)) 

(ferror nil "ASH macro uas not given a numeric shift count, ") 
(i f (minusp count) 

• (ashr , val . (- count) ) 
Mashl ,val .count)))) 

(defmacro I sh (va! count) 
(if (not (numberp count)) 

(ferror nil "LSH macro uas not given a numeric shift count.") 
(i f (minusp count) 

MIshr .val , (- count)) 
MIshI ,val .count)))) 
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(defmacro set-fieids (object Arest pairs) 

Mprogn .•(loop for (field value) on pairs by 'cddr 
col lect (if (1 ietp field) 

(do ((ans value Msetf (, (car fields) .object) .ans)) 
(fields field (cdr fields))) 
((nul I fields) arts)} 
'(setf (.field .object) .value))))) 

(defr.acro menber (thing 'items) 

(loop with gensym • (gensym) y^ 

for item in items collect * (• , gensym .item) into clauses 
finally {return MIet ((.gensym .thing)) 

(or ,«clause3))))) 

(defcacro externals (irest forms) 

* (progn .•(loop for (fun , args) in forms 

collect ^external , f un .(loop for arg in args 

collect M.arg ,arg)))))) 

(def macro let*-global iy (lambda- list 4body body) 
(loop for (var val) in lambda- list 
as gensym - (gensym) 

collect '(.gensym (progl ,v^r (setq ,var .val))) into bindings 
collect '(setq ,var .gensym) into unbindings 
finally (return '(let* .bindings 

(progl (progn .•body) 

.•(reverse unbindings)))))) 

(def macro let-globally (lambda- list ibody body) 
(Joop for (var val) in larabda-list 
as gensym • (gensym) 
collect '(.gensym .var) into savings 
nconc M.var .val) into bindings 
collect '(setq .var .gensym) into unbindings 
finally (return '(let .savings 

(psetq .•bindings) 
(progl (progn .•body) 

.•(reverse unbindings)))))) 

(defmacro funcal l-for-value ((type pointer-type) fun Arest args) 
(let ( (gensym (gensym) ) ) 
•(let (((.gensym .type))) 

(funcal 1 .fun (make-pointer .pointer-type .gensym) .•args) 
.gensym) ) ) 

(defmacro ui thout-interrupts (firest forms) 
'(progn .•forms)) 

(defatOKBacro TIPIE-as-long '(coerce long TlflE)) 

(deftype event-channel (pointer event-mask)) 
(deftype event-mask long al lou-ar i thmet ic t) 

(defatoflimacro +INF *;if, (1- 1_31.)) ;big enough 
(externa! (grab-spy-bus boole) ((no-hang-p boote))) 
(external ungrab-spy-bus ()) 

(defmacro wl th-spy-bus-grabbed (fibody body) 
•(progn (grab-spy-bus false) 

(progl (progn .•body) 

(ungrab-spy-bus) ) ) ) 

(defmacro spy-write (where val) Msetq ,uY^^r^ ,val)) 
(defmacro fep-wr i te-io-word (where vaM *{setq .where ,va!)) 
(defmacro spy-read (where) where) 
(defmacro fep-read-io-word (where) where) 
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;Thi9 feoduie is in charge of the SQ board 

; Spy Address definitions 

(def-io spy-cmem micro instruct ion) 

(def-io spy-sq-board-id byte) 

(def-io spy-sq-cti (array byte 2)) 

(def-io spy-sq-status (array byte 2)) 

(def-io spy-next-cpc (array byte 2)) 

(def-io spy-opc (array byte 2)) 

(def-io spy-tasK byte) 

(def-io «py-ct08-high byte) 

(def-io epy-»q-statu82 byte) 
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;13 bytes of control -memory read/ur i te data 

;Urite9 the CMEfl WD registers, reads the UIR 

tRead board ID prom (indexed by U ATiRA) 

iUritc SO control register (2 bytes) 

;Read SQ status (2 bytes) 

{Read NEXT CPC lines (2 bytes) 

sRead micro PC history memory (2 bytes) 

;Read current task number 

:Read bits 14,15 of CTOS 

{Plisc status bi ts 



(def-io fep-board- id-control fep-board-id-control ) 

(def-io fep-seriat-dma-and-clock-ctt fep-ser-dma-control ) 

(def-io fep-d»a-control byte) 

(def-io fep-proc-control fep-proc-control ) 

(def-io fep- 1 bus-control fep- 1 bus-control) 

(def-io spy-dma-control ler dma-control ler) 
(def-io spy-dma-high-addrs (array byte 4)) 

(def-io fep-padd I e- id-prom (array byte 49)) 
(def-io fep-board- id-prom (array byte 40)) 

(def-io mp3c-0-a mpsc) 

(def-io mpsc-fl-b mpsc) 

(def-io mpsc-l-a mpsc) 

(def-io mpsc-l-b mpsc) 

(def-io fep-ser iaI-baud-rate-0 uord) 

(def-io f«p-»erial-baud-rate-l word) 

(def-io spy-net-sclect byte) 
(def-io spy-net-centrol byte) 

(def-io fep-hsb-control fep-hsb-control ) 
(def-io fep-hsb-data word) 
(def-io fep-hsb-po inter uord) 

(def-io p-port word) 



(deftype Sbytes (array byte B)) 

(deftype hsb-ethernet-address-type Sbytes) 

;;; Lbus related defs (the OFFICIAL file is 

; 8: 1774000 - 1774007, 1000000 - 1001777 

: 1: 1774010 - 1774017, 1002000 - 1003777 

; 2: 1774C20 - 1774027, 1004000 - 100S777 

; 3: 1774030 - 1774037, 100B000 - 1007777 

; 4: 1774040 - 1774047, 1010000 - 1011777 

;-5: 1774050 - 1774057, 1012000 - 1013777 

: 6:. 1774050 - 17740S7, 1014000 - 1015777 

(def atommacros 

( J bus-map-s i ot-f or-conso I e-program 

( lbu«-»ap-8 I ot-f or- I oader-dumper 

( I bus-map-8 1 ot-f or-tystem-commun i cat i on 

(Ibus-map-slot-for-random-fep-read-wr i te 

( I bus-«ap-s I o t- f or- fep-di splay-memory 

( I bus-map-s I ot-f or- iob-regs 

( I bus-map-s I o t- f or-s I ou-d i sk- 1 oad i ng 

} 



SCRC:<LFEP>AODRS.TEXT 

Reserved for console program 

Reserved for loader/dumper 

Reserved for system communications area 

Reserved for FEP random reads/writes 

Reserved for FEP manipulation of display memory. 

Reserved for fE? maniput lat ion of ID board regs. 

Reserved for FEP slow disk loading 



0) 
1) 
2) 
3) 
4) 
5) 
6) 



(def atoRmacro I og- 1 bus-page-s i ze * 8. ) 

(defatommacro I bus-page-s ire Mlshl 1 log-lbus-page-size)) 

(defatommacro tbus-address-of fset-mask '(1- Ibus-page-size)) 

(def macro I bus-address-page (address) Mldb- typed uord ;ftfol020 , address)) 

(defmacro ibus-address-of f set (address) MIdb-typed uord <fo0010 , address)) 
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(deftype tbus-word (structure (preserve-order t) 
(data long) 
(ecc+high word)) 
default-mode ref) 
(deftype Ibus-word-ptr (pointer Ibus-uord)) 

(deftype Ibus-map-siot (structure (preserve-order t) 

(address word) 
(ecc+high word) 
(data 8 long) 3 
volati le t) 

(deftype Ibus-map-slot-ptr (pointer ibus-«ap-slot) ) 

(deftype Ibus-data-page (array slong I bus-page-si re) 
vo tat i le t) 

(deftype Ibus-data-page-ptr (pointer Ibus-data-page) ) 

(defmacro (ong-into-lbus-word (val ^optional (dtpD) 
(let (((ud Ibus-word)}) 
(setf (data wd) ,val) 
(setf (ecc+high ud) ,dtp) 
yd)) 



F:>Lnach>Fep>str ing-dofs. I i 1 ,21 



(defatommacro ENTIRE-STRING -1) 
<defatommacro STRING-SEARCH-FAILED -1) 

(deftype string (pointer string-type auto-dereference t)) 
(defatommacro NULL-string * (»ake-nul l-pointer string)) 
(deftype str ing-type-headcr (structure (J 

(constant-string? boole) 

(string- length word); active length 

(string-sire word) ;al located 

}) 
(deftype string-type (structure (include string-type-header) 

(string-bytes «byte-array) ) ) 

(defmacro string-constant (string) 
• (make-pointer string 

(constant string- type 

constant-string? true 
string-length , (string-length string) 
String-sire , (str ing-iength string) 
string-bytes (constant 

»byte-array 

.•(loop for ch being the array-elements 

of string col lect ch) 
,»(if (zerop (string-length string)) 
M8) 
()))))) 

(defmacro cstring (drest rest) * (str tng-constant ,«rest)) 

• • — 

;;;;;; F:>LHach>Fep>process-defs. I i I . 19 
f • 

(deftype process-state (enumeration 

running runnable stopped waiting logging-out) ) 

(deftype process (pointer process-type auto-dereference t)) 
(defatommacro NULL-process * (make-nu I 1 -pointer process)) 
(deftype process- type-header (structure 

(next-process- 1 ink process) 

(prev-process-( ink process) 

(process-name string) 

(initial-function long) 

(process-state process-state) 

(uhostate string) 

( last-whostate string) 

(flush-routine long) 

(rea!-f lush-routine long) 
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(flush-arg-1 long) 
(flush-arg-2 long) 
(flush-arg-3 long) 
{fiush-arg-4 long) 
(binding-list bind-block) 
(saved-stack-ptr long) ) ) 
(deftypc ppoccss-type (structure (include process-type-header) 

(process-stack (array long «)))) 

(deftype bind-block (pointer bind-b lock-type auto-dereference t)) 
(defatomiracro NULL-bind-block ' (make-nul I -pointer bind-block)) 
(deftype bind-b lock-type (structure 

(next-btnd-block bind-block) 

(size uord) 

(ptr long) 

(val long))) 

(def«acro wi th-var-bound (var-ptr 4body body) 
'(let (((bbt bind-biock-typc))) 
(set-fields bbt 

next -bind-b lock (binding- list current-process) 
sire (type-size- instance •, var-ptr) 
ptr (coerce long , var-ptr) 
val (coerce long •.var-ptr)) 
(setf (binding-list current-process) (make-pointer bind-block bbt)) 
(progl 

(progn ,«body) 

(swap-bind-b lock-value (make-pointer bind-block bbt)) 

(setf (binding-list current-process) (next-bind-block bbt))))) 

(external suap-bind-b lock-value ((bind-block bind-biock))) 

(defmacro process-watt (uhostate function Arest arguments) 
•(.(nth (length arguments) 
* (process-uai t-d 
proccss-ual t-1 
process-uai t-2 
process-uiai t-3 
process-uai t-4) ) 
♦whostate 
, funct ion 
.•(locp for arg in arguments 

collect '(coerce long ,arg)))) 

(defmacro process-run-function (name function 4rest arguments) 
• (process-run-f unct i on-aux 
.name 
, funct ion 

(uord .(length arguments)) 
.•(loop for arg tn arguments 

collect • (coerce long ,arg)) 

.•(loop for i upfro» (length arguments) below 4 
collect '(long 0)))) 

(external deschedule ()) 

(external process-uai t-8 < (us string) (fun long))) 

(external process-wai t-1 f(ws string) (fun long) (al long))) 

(external process-war t-2 ((ws string) (fun long) (al long) (o2 long))) 

(external process-uai t-3 ( (w« string) (fun long) (al long) (a2 long) (a3 lonn))) 

(external process-wai t-4 ((ws string) (fun long) (al long) (a2 long) (a3 long) 

(a4 long))) 
(external (process-run-function-aux process) ((name string) 

(function long) (numargs word) 
(argl long) (arg2 long) 
(argS long) (arg4 long))) 

(external process-sleep ((interval long))) 
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;; F:>Lnach>Fep>stpea»-def». 1 t 1,9 



;;; Note to tmplementers: functions get SELF as their first argument. 

(external init-streams ()) 

(external (al locate-streafn stream) ((size long))) 

(external return-stream ((stream stream))) 

(def macro defstreamf unction (function arg-specs opt ional -stream) 

Clet» { (funct ion-naac (if (listp function) (car function) function)) 

(sf unction-name (intern (format nil ■STREATt-^A" function-name) "LIL")) 
(sfunction (if (listp function) *(, sf unction-name ,«(cdr function)) sf unction-name)) 
(args (mapcar tt* zBr arg-specs))) 
• (progn (def macro .function-name (,«args 4opt ional (stream \ opt ional -stream)) 
(list '.sf unction-name ,«args stream)) 
(external ♦sfunction (.©arg-specs (stream stream)))))) 

(defstreamfunction tyo {(char byte)) standard-output) 

(defstreamfunction (tyi byte) standard-input) 

(defstreamfunction (kbd-tyi -no-hang boole) standard- input) 

(defstreamfunction (tyi-eof byte) ((eof-option boole node ref)) standard-input) 

(defstreamfunction terpri standard-output) 

(defstreamfunction fresh-line standard-output) 

(external stream-close ((stream stream))) 

(defstreamfunction print-octai ((number long)) standard-output) 

(defstreamfunction print-number ((number word) (base word)) standard-output) 

(defstreamfunction print-string ((string string)) standard-output) 

(defstreamfunction print-substring ((string string) (from word) (to word)) standard-output) 

(defstreamfunction print-bytes ((bp byte-ptr) (aax-chars word)) standard-output) 

(def type stream-ptr (pointer stream)) 

(def type stream (pointer stream-type auto-dereference t)) 
(defatommacro NULL-stream * (make-nul l-pointer stream)) 
(deftype stream-type (structure 

(x-pos word) 

(y-pos word) 

(for-tyo long) 

(for-tyi-eof long) 

(for- tyi -no-hang long) 

(for-close long) 

(for-terpr i-or-fresh-I rne long) 

)) 
» 5 
•;;;;; F: > I «ach> f ep>FORriAT, li 1 . 1 

♦ • 

(def macro format (stream string . args) 

(if (stringp stream) (terror nil "You forgot the stream as first arg to FDRHAT.") 
(If (cq stream 't) (setq stream 'standard-output)) 
' (progn 

.•(loop wi th from - 

for to - (string-search-char U/*^ string from) 
when (or (not to) (^ from to)) 

collect '(print-string .(substring string from to) .stream) 
whi le to 

collect (selector (aref string (1+ to)) char-equal 
(^/X '(tyo ;y\space .stream)) 
inn '(terpri .stream)) 
(#/4 '(fresh-line .stream)) 
{U/Z '(tyo .(pop args) .stream)) 
iU/^ '(print-octal .(pop args) .stream)) 
(#/D '(print-number .(pop args) 10. .stream)) 
(tf/A '(print-string .(pop args) .stream)) 
iU/S '(progn (tyo U/" .stream) 

(print-string , (pop args) .stream) 
(tyo n/" , stream))) 
ittfl '(print-substring .(pop args) 

, (pop args) , (pop args) 
.stream) ) 
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itt/B • (print-bytes .(pop args) , (pop args) .stream)) 
(#/U *(print-word (coerce *t>yte-array-ptr , (pop args)) 

.(pop args) .stream)) 
iff/U Mstrcam-print-microinstruction .(pop args) .stream)) 
(otheruise (ferror nit "Bad character *€ in format string" 
(aref string (1+ to))))) 
do (sctq from (+ to 2) ) 
while (< from (string-length string)))))) 

(def macro f debug (mask mask-name string • args) 
(if (member mask-name 

#+5DLC M) ;FEP working pretty wsit these days 

<f-BDLC • ;it works in the omnibyte 

) 
Mif (* (logand .mask .mask-name) 0) 

(format debug-io .string . .args)) 
' (setq junk junk))) 

; ; i 1 ; ; F: >Lnach>Fep>network-def 1. li 1 .29 
» » 

;: 
;;;;:; Parameters 
« s 

(defatommacro n-genera I -drivers 'IfiJ 

(dcfatommacro length-gpkt-hardwarc-pref ix |28.) 
(defatommacro Icngth-gpkt-other-ncp-f ietds '28.) 

(defatommacro length-gdrv-other-ncp-f ields '20.) 

;:;;;; General packet definition 
* t 

(def type gpkt (pointer gpkt-type auto-dereference t)) 
(defatommacro NULL-gpkt ' (make-nul I -pointer gpkt)) 

(def type 
gpkt-type-tiesder 
(structure (preserve-order t) 

igpkt-type-header-bytes (array byte 8)) ;place holder for copy 
(gpkt-error-message string) 
(gpkt-user-1 ink gpkt) 
(gpkt-xmit-link gpkt) 
(gpkt-on-a-user- 1 i st? boo I c) 
(gpkt-on-an-xmi t-l ist? boole) 
(header-byte-format byte-format) 
(data-byte- format byte- format) 
(gpkt-user-f lags word) 
(» (union (gpkt-user-byte-pointer word) 
(gpkt-altocated-size word) 
(gpkt-transmi t-size word))) 
(* (union (gpkt-user-byte-count word) 

(gpkt-receive-timc clock-value) 
(gpkt-xmit-time clock-value))) 
(* (union 

(gpkt-other-ncp-f ields (array byte Icngth-gpkt-other-ncp-f telds) ) 
(gpkt-other-ncp-fi elds-words (array word 8)))) 
(gpkt-hardware-prefix (array byte length-gpkt-hardware-pref ix) ) ) ) 

(deftype gpkt-type 

(structure (include gpkt- type-header preserve-order t) 
(« (union (gpkt-data-bytes (array byte «) ) 
(gpkt-data-words (array word «)) 
(gpkt-data-longs (array long «)))))) 

(deftype byte-format (enumeration bf-internal 

bf-bytes bf-bytes-backwards 
bf-words-lr bf-words-r I ) ) 
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network driver support 



(deftype genera I -dr iver (pointer genera I -dr iver-type auto-dereference t)) 
{defatomrracro NULL-general -dr i ver ' (make-nul I "-pointer genera I -driver) ) 
(deftype 
genera I -dr i ver -type 
(structure 

(gdrv-xmi t- I i St gpkt) 
(gdrv-xmi t-tai I gpkt) 
(gdrv-current-output-pkt gpkt) 
tgdrv-stat i St i cs netuork-stat i st Ics-type) 
(* (union 

(gdrv-o ther-ncp- fields (array byte I ength-gdrv-other-ncp-f I elds)) 
(» (sequence 

(send-an-ethernet-packet long) 
(ethernet-address (array byte B)) 

(send-a-chaos-packet long) 
(chaos-address word) 
(chaos-subnet word) 
(chaos-dr i ver-nuffiber+l word) 



)) 



)) 



)) 



Statisicts structure 



(deftype network-stat ist ics-type 
(structure 


(packets-in long) 

(packets-out long) 

(packets-aborted long) 

(packets- lost I ong) 

(packets-crc-error long) 

'"(packets-ram-error long) 

(packets-bi tc-error long) 

(packets-other-reject long) 
)) 



(defmacro network-meter (driver field • increment) 
lLln£L.<'*»eld (gdrv-stati sties .driver}) . , increment)) 



; ; ; F:>Lnach>Fep>ethernet-def s. 1 i 1 .18 



(defmacro etherword (word) 
*f-BQLC word 
A+BDLC Mrotr (word .word) 8.)) 



(def atomrcacros 

(ether- typeSXerox-PUP 

( ether- typetXerox-NS 

(ether- typelDOO-Internet 

(ether-typeSCHAOS 

(ether-typefiADDRESS-RESOLUTION 

) 



(etherword Afx+e2ea) ) 
(etherword Ux-t-QSZZ)) 
(etherword ffx^BSBd)) 
(etherword /^x+eE04) ) 
(etherword #x+8581)} 



(defatommacros 

(ether- 1 cngthSXerox-PUP 
(ether- I ength«Xerox-NS 
(ether- lengthtDOD-Internet 
(ether- lengthfCHAOS 
) 



1) 
6) 
4) 
2) 



(defatommacros 

(ether-ares-oplrequest Metherword D) 
(ether-ares-optreply * (etherword 2) ) \ 
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(def type ethernet-address-resolut ion-biock 
(structure 
-<* (union (earb-bytes (array byte 12.)) 
(carb-uords (array uord 0S.3) 
(earb-Icngs (array long 83.)))))) 
(def type ethernet-address-ptr (pointep ethernet-address-array-type) ) 
(def type ethcrnct-address-array-type (array byte B)) 



(def type ethernet-associ at ton-entry 
(structure 

(eae-protccoi uord) 
(eae- length uord) 
(eae-recs i ver t eng) 
(eae-pa-of fset uord) 
)) 



;protocol being talked 

; length of address in the protocol 

; routine to receive a packet 

;offset into gdrv to protocol address 



(def type ethernet-trans I at ion-entry 
(structure 

(ete-protocol uord) 

(ete-ethernet-address ethcrnet-address-array-type) 

(e te-pro toco I -address e therne t-address-reso 1 ut i on-b 1 ock) 

)) 

• • 
?:;;;; F:>Lnach>Fep>chao9-def8. t i L38 



NCP parameters 



(defatoirmacro chaos-wax-conns 18) 
(defatociRiacro aax-subnet '54) 



Global states 



(defatommacro UNXNOUN-CHAOS-ADDRESS -1) 
(dcfatommacrd" UAIT-FDREVER -1) 
(defatommacro FOREVER VINF) 



Parameters 



(defatommacro DEFAULT-U1ND0U-SI2E 5.) 
(defatommacro maximum-uindou-size 28.) 



CHAOS Packet opcodes 



(defatommacros 
(rfc-op 881) 
(opn-op 882) 
(cIs-op 883) 
(fud-op 884) 
(ans-op 885) 
(sns-op 88S) 
(sts-op 887) 
(rut-op 818) 
(I OS-op 811) 
(Isn-op 812) 
(mnt-op 813) 
(eof-op 814) 
(unc-op 815) 
(brd-op 81S) 



; request for connection 

: accept a connection 

iclose a connection 

; 8 i gna I f oruar d i ng 

;ansuer a simple connection 

; sense a connection 

;give status of a connection 

{distribute routing information 

;you are losing 

; listen for a request 

; maintenance 

;**end of f i le" 

;uncontrot led 

{broadcast request 



(HAX-OP 817) 



;aluag8 last non-data 
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idat-op 209) ;8.bit data 

(dwd-op 388) ;16.bit data 

)- 



CHAOS connection states 



(deftype connection-state (enumeration 

inactive-state 

open-state 

rfc-sent-8tate 

ansuered-state 

c 1 8-pecei ved-state 

los-pecetved-state 

host-doun-state 

I istening-state 

rfc-received-state 

foreign-state 

brd-sent-state 

brd-recei ved-state 

)) 



packet def ini t tons. 



(defatomiracro max-longs-per-pkt 12S.) 

(defatommccro max-words-per-pkt 252.) 

(defatommacro max-bytes-per-pkt 5£4.) 

(defatonmscro max-data-Zongs-per-pkt 122.) 

(defatcmmacro max-data-uords-per-pkt 244.) 

(defatommacro max-data-bytes-per-pkt 4£S.) 

(defatcmmacro f irst-data-long-in-pkt 4.) ;offset in longs 

(defatommacro f irst-data-word-in-pkt 8.) ;offset in words 

(defatommacro f irst-data-byte-in-pkt IG.) ;offset in bytes 

(deftype pkt-ptr (pointer pkt)) ;yup WW 
(deftype pkt (pointer pkt-type auto-dereference t)) 
(defatommacro NULL-pkt ' (make-nul 1-pointer pkt)) 
(deftvpe pkt-type 

(structure (include gpkt-type-header preserve-order t) 
(* (union 

(pkt- tongs (array long wax- tongs-per-pkt) ) 
(pkt-uords (array uord max-uords-per-pkt) ) 
(pkt-bytes (array byte max-bytes-per-pkt) ) 
(* (sequence 

(« (union 

(pkt-header-longs (array long first-data- tong-tn-pkt) ) 
(pkt-header-wcrds (array word f irst-data-word-in-pkt) ) 
(pkt-header-bytes (array byte f irst-data-byte-in-pkt) ) 
(* (sequence 

<?+BDLC (pkt-mbz byte) 
(pkt-opcode byte) 
#-BDLC (pkt-mbz byte) 
(pkt-nbytes word) 
(« (union 

(* (sequence 

(pkt-dest-port long) 
(pkt-src-port long) ) ) 
(4c (sequence 

(pkt-dest-address word) 
(pkt-dest-index-num word) 
(pkt-src-address word) 
(pkt-src-tndex-num word) ) ) 
(* tf+BDLC (sequence 

(pkt-dest-host-num byte) 
(pkt-dest-subnet byte) 
(pkt-dest-idx byte) 
(pkt-dest-uniq byte) 
(pkt-src-host-num byte) 
(pkt-src-subnet byte) 
(pkt-src-idx byte) 
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(pKt-src-uniq byte)) 
^-BDLC (sequence 

(pkt-dest-subnet byte) 
(pkt-deat-host-num byte) 
(pk.t-ciest-unfq byte) 
(pkt-dest-idx byte) 
(pkt-src-aubnet byte) 
{pkt-src-host-num byte) 
(pkt-5PC-untq byte) 
(pkt-src-idx byte)) 
))) 
(pkt-num word) 
(pkt-ack-num word))))) 
(* (union 

(* (sequence 

(pkt-f irst-data-wopd word) 
(pkt-sccond-data-uord word))) 
(pkt-data-longs (array long max-data- longs-per-pkt) ) 
(pkt-data-ij-rds (array word max-data-words-per-pkt) ) 
(pkt-data-bytes (array byte wax-data-bytes-per-pkt)} ))))))) ) 
I ; jLirpfl conpv^t ibi I i ty 
(defnacro pkt-link (pkt) Mcoerce pkt (gpkt-user-l ink .pkt))) 

; ;;u?er friend! iness 

(defwccro pkt-srror (ckt) * (askt-crror-message .pkt)) 



connection definitions 



(deftype conn (pointer conn-type auto-dereference t) ) 
(defatommacro tflJLL-conn * («iake-nul l-pointer conn)) 
tdeftupe 
conn-type 
(structure 

(conn-error-nessage string) 
(conn-error-conn booie) 
( I oca I -w i ndow-s i ze word) 
(foreign-window- size word) 
(state connection-state) 
(connect ion-needs-status boole) 

(* (union (» (sequence (foreign-port long))) 
(« (sequence (foreign-address word) 

(forcign-index-num word))) 
(« #+BDLC (sequence (foreign-host-num byte) 
(foreign-subnet byte) 
(foreign-idx byte) 
(foreign-uniq byte)) 
<^-BDLC (sequence (foreign-subnet byte) 
(foreign-host-num byte) 
(foreign-unfq byte) 
(foreign-idx byte)) 
))) 
(* (union f« (sequence ( I oca I -port long) ) ) 

(» (sequence (local-address word) 

( local -index-num word))) 
(« #+BDLC (sequence ( local -host-num byte) 
(t oca I -subnet byte) 
(local-idx byte) 

(local-uniq byte)) 

)I?-BDLC (sequence ( I oca! -subnet byte) 
( local-host-num byte) 
(local-uniq byte) 

(local-idx byte)) 

))) 
(read-pkts • pkt) 
(resd-pkts-last pkt) 
(recei ved-pkts pkt) 



(pkt-num-read word) 
(pkt-num-recei ved word) 
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(pkt-num-acked word) 
(t rme- last-recei vcd clock-value) 
„ (auto-status-threshold word) 

;ECt to window size when acking is done (data or 

;5TS pkt goes out). DECFed by 3 for each packet 

;read. If this hits zero or below, an ST5 is generated. 

(stream-input-pkt pkt) 

(pKt-rece ( ve-event-mask event-mask) 

(pkt-receive-event-channel event-channel) 

■ (send-pkts pkt) 
(send-pkts-last pkt) 
(send-pkts- length word) 
{pkt-nurn-sent word) 
(send-pkt-acked word) 
(window-available word) 

(stream-output-pkt pkt) 

(pkt-xmi t--event-mask event-mask) 

(pk t-xm i t-evcnt-channe I event-channe I ) 

)) 

;;; mc*"e user friendliness 
(detracro ccnn-error (conn) * (conn-error-message .ccnnU 

(def type server-af ist-entry (structure 

(server-contact-name string) 
(eerver-run-rout ine long))) 

(deftijpe chaos-stream-charactep-set (enumeration cscs-lispm cscs-supdup cscs- telnet)} 

(def type chaos-stream (pointer chaos-stream-type auto-dereference t)) 
(defir.acro N'JLL-chaos-stream * (make-nul I -pointer chaos-streai)) ) 
(def type chaos-strcam-type (structure (includa stream-type) 
— (conn-for-stream conn) 

(character-set chaos-stream-character-set) ) ) 



F: >Lnach>rep>iob-def s. I i I . 1 



Definitions for the L-Hachlne 10 Board 



(def atommacro *di sk-command-of f set* 0) 
(defatcmmacro «di sk-ecc-of f set* 1) 
(defatommacro «di sk-status-of f set* 2) 
(defatommacro *di sk-rps-of f set* 3) 
(defatonmacro «net-status-of fset* 4) 
(defatommacro «net-diag-of f set* 5) 
(defatommacro «vd-status-of f set* S) 
(defatommacro *vd-di ag-of f set* 7) 
(defatommacro *padd ! e-of f set* 10) 
(defatommacro *pio-status-of f set* 11) 
(defatommacro *pio-data-of f set* 12) 



sread/wr i te 

;read 

! read/write diagnostic 

\read 

;rcad/wr i te 

:wr i te 

iread/wr i te 

;read 

;read/wr i te 

;read/wr i te 

;read/wr i te 



(defatommacro «sync-memory-of f set* 1_17.) 
(defatommacro «di sp I ay-memory-offset* 1_1S. ) 
(defatommacro *di splay-data-of f set* 4800) 

(defmacro feo-read-di sk-status 
,7sctq *last-fe^-read-disk-status* (read-iob-reg *di sk-status-of fset*) ) ) 

;: F:>Ln3ch>Fep>disk-defs. I i 1.30 



(dsftuce f i lenane-name (array byte 22.)) 
(deftyoe f i lename- type (array byte 4?)) 
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(deftuDe paoR-state (enumeration ps-read ps-writc ps-orrcr)) 

(deftvce disk-tncrfe (enumeration dn-character dm-bu"^e dm-uord dm- 1 ong dm-3Sfc't dn-biocK)) 

(deftype disk-direction (enunierat ion dd-read dd-uritii dd-update)) 

ideftype filename (structure 

(name f i lename-name) 
(type f I lename-type) 
(vers i en I ong) ) ) 

idefzocro cfttename (string) 

(let* ((ft (string-search-char #/. string)) 

(tv (str ino-scarch-char tf/. string (1+ ft))) 
(name (suDstring string 2 ft)) 
(type (substring string (1+ ft) tv)) 

(ver (let* ((ibase 18.)) (read-from-string (substring string (1+ tv)))))) 
• (constant f i I ename 

name (cfi lename-name ,name) 
type (cf i f ename-type , type) 
versi on , ver) ) ) 

(defmacro cf i lename-name (string) * (cbytcs filename-name .string 32.)) 
(defnacro cf i lenams-tupe (string) '(cbytes filename-type .string 4)) 

(defmacro header-type-to- long (header-type) 
{ looD ui th long « 8 

for ch being the array-elements of header-type 
do (setq long (+ (ash long 8) ch)) 
finally (return long))) 



Data stucture of disk pages (these need SLONGing) 



; ; ; rau. just data 

(deftupe disk-data (pointer disk-data-type auto-dereference t)) 
(dcfatommacrc NULL-di sk-data * (make-nu I i -pointer disk-data)) 
(deftype disk-data-type (structure 

(* (union 
— (disk- longs (arrai^ long 2S3. ) ) 

(dtsk-uords (array word 589.)) 
(disk-bytes (array byte 1168.)) 
(disk-slongs (array siong 238.)) 
(« (sequence 

(disk-header-longs (array long 2)) 
(* (union 

(disk-data- longs (array long 2SS. ) ) 
(disk-data-words (array word 57G. ) ) 
(disk-data-bytes (array byte 11S2. ) ) 
(disk-data-slongs (array si ong 2S3.)) ;stgh 
)))))))) 

(defatdPmacro page-size '(type-sire di sk-data-type) ) 

(defatoamacro page-data-stze * (type-size (di sk-data- longs disk-data-type))) 

;;; everything else starts with one of these 

(deftype di sk-page-header (structure (preserve-order t) 

(check-header-1 si ong) 

(check-header-2 si ong) 

(type slong) 

(header-version slong) 

(npages slong) 

(TAD-written slong) 

(sequence-number s I ong) 

)) 

(deftype disk-LABL (pointer di sk-LABL-type auto-dereference t)) 
(defatommacro NoLL-di sk-LABL ' (make-nul !-pointer disk-LABD) 
(deftupe di sk-LABL-type (structure (include disk-page-header 

preserve-order t) 

(ncy I inders slong) 

(nheads slong) 
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(npages-per-track siong) 
(creation-info (array byte 22.)) 
(pack-name (array byte 32.)) 
(cornment (array byte S5.)) 
(dpn-of-root-directory slong) 
(pack-id slong) 
)) 

(cefatcrrracro npages-mack^tf. (- l_2^. D) 

(defracro pmap';' (pmap-npagesl Mnot (rerop (logandl_24. .ptnap-npages) ) ) ) 

(dfc/ type pnap-entry (structure (preserve-order t) 

(npages siong) 

(dpn slong))) 

(oeftyoe disk-FEPF (pointer di &k-FEPF-type auto-dereference t)) 
(defatcmmacro NULL-di sk-FEPF ' (make-nut 1-pointer disk-FEPF)) 
(deftype di sk-FEPF- type (structure (include disk-page-header 

preserve-order t) 

(ouning-dir-seq slong) 

(f ( le-version siong) 

(file- type f i I ename-type) 

(creation-info (array byte 32.)) 

(file-name filename-name) 

(comment (array byte 3B. ) ) 

(byte-length slong) 

(bits slong) 

(number-of-jntr ies stong) 

(page-map (array pmap-entry 9)) 

)) 

(deftype FEPD-entrg-ptr (pointer FEFO-entry auto-dereference t)) 
(deftype FEPD-entry (structure (ppeserve-order t) 

(name f i lenarae-narae) 

(type f i iename-type) 

(version s)ong) 

(header-dpn elong))) 

(deftype disk-FEPD (pointer di sk-FEPD-type a^^°-^=^^^%=Sm /' ^ 
(defato«acro NULL-di sk-FEFD • (make-nul l-po»nter d.sk-FEPD)) 
(deftype disK-FEPD-type (structure (include disk-page-header 
* preserve-order t) 

(dir-data-page-num slong) 
(« (array stong UA- 14 S -1))) 
(nentries slong) 
(entries (array FEPD-cntry 22)) 
)) 



Internal representations (these do not need slongs) 



(deftype dpn-and-count (structure 

(dpn long) 
(count long))) 

(deftype file-stream (pointer f ite-stream-type auto-dereference t)) 
(defatcmmacro NULL-f i le-stream * (make-nul i-pointer file-stream)) 
(deftype f i le-stream-type (structure 

(error-message string) 

(f i lename f i lename) 

(mode disk-mode) 

(direction disk-direction) 

(disk-unit word) 

(f i le-header-dpn long) 

(f i te-header-page disk-page) 

( i nf er i or-page-map-dpn I ong) 

( i nf er i or-page-map-page d i sk-page) 

(current-dpn long) 

(current-disk-page disk-page) 

(current-b I ock-number 1 ong) 

(des i red-b t ock-number I ong) 

(current-byte-offset uord) 

(current-mode-offset word) 

)) 
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(deftype di sk-page-ptr (pointer disk-page)) 
(defatommacro NLTLL-di sK-pagc ' (make-nul i-pointer disk-page)) 
(deftype disk-page (pointer disk-page-type auto-dereference t)) 
(deftype disk-page-type (structure 

(error -message string) 

(next-disk-page-link disk-page) 

(di sk-uni t word) 

(dpn long) 

(usage-count uord) 

(page-state page-state) 

(page-needs-ur i t ing boole) 

(header-type long) :labl, fepf, etc 

(* (union 

(disk-data disk-data) 
(dtsk-LABL disk-LABL) 
(disk-FEPF disk-FEPF) 
(disk-FEPD disk-FEPD) 
)) 

)) 
;; 

; F: >Lnach>Fep> I oad-wor ! d-def s. 1 1 1 . 3 



(deftype boot-status (enumeration 
bs-succes« 

bs-no-boot-status 
bs-power-not-ok 

bs-ra i crocode-un i t-se I ec t-error 
bs-» i crocode-open-error 
b»-»icrocode-f i le-error 
b8-« i crocode-vcr i f y-crror 

bs-uor !d-unt t-se!ect-crror 
bs-wor I d-open-error 
bs-world-fi le-ver i fy-error 
bs-wor I d-f i I e-error 

bs-sparse-veri fy-error 
bs- I oad- initial -error 
bs- I oad-«ap8-error 
bs-pre I oad- I oad-error 
bs-phtc-se tup-error 
)) 

(deftype load-«ap-entry (structure 

(star t i ng-vma I ong) 

(number-of-words long) 

( f i 1 e-page-number I ong) 

(d i sk-page-number I ong) ) ) 
(deftype load-«ap-array (pointer load-nap-array-type) ) 
(deftype load-«ap-array-type (array load-nap-entry *) ) 

;;;;;; F:>Lnach>Fcp>dcfword, I i 1 #3 

(defstreamf unction print-word ((word *byte-array-ptr) (wd word-description)) standard-output) 

(deftype value-names* (array string «> ) 
(deftype f ield-descrtpt ton- type (structure 

(name string) 

(print-name boole) 

(ss byte) 

ipp word) 

(n-value-names word) 

(value-names value-names*))) 
(deftype field-description (pointer field-description-type auto-dereference t)) 
(defatommacro NULL-f ield-descr ipt ion '(make-null-pointer field-description)) 
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(deftype uord-descr ipt ion-type (array f ield-descr ipt ton *) ) 

(deftype word-description (pointer word-description-type auto-dereference t)) 

(defatommacro NULL-word-descr ipt ton ' (make-nu I (-pointer word-description)) 

(def macro defword (name ignore fibody field-descriptions) 
(loop with pp with ss with value-names 

for (type field-name , fd-rest) in field-descriptions 
for field-nuMber up from 8 
do (if (listp field-name) 

(setq print-name (if (second field-name) 'true 'false) 

field-name (or (second field-name) (first field-name))) 
(setq print-name 'true)) 
do (seiectq type 

(:byte (setq pp (second fd-rest) 
ss (first fd-rest) 
value-names (nthcdr 2 fd-rest))) 
(:bit (setq pp (first fd-rest) 
ss 1 
value-names (and (cdr fd-rest) 

(list (third fd-rest) (second fd-rest))))) 
(otherwise (warn *^^A is an unknown field type in defword -^A" type name))) 
collect '(make-pointer field-description 

(constant f ield-descr ipt ion- type 

name , (string field-name) 
print-name , print-name 
PP .PP 

ss ,83 

n-value-names .(length value-names) 

value-names 

(constant value-names* 

♦•(loop for vn in value-names 
col lect (i f vn 

'♦ (string vn) 
*NULL-string)) 
,«[if value-names ' (NULL-str ing) ) )) ) 
into field-descriptions 

finally (return Mdefconst .name word-description 
(make-pointer word-description 
— (constant uord-descr ipt ion-type 

, ©f i e I d-descr i pt i ons 
NULL-f i e 1 d-descr t pt i on) ) ) ) ) ) 
; ; ; ; Gross & ugly 

; These are local to the command decoder 

(deftype command-dispatch-table-entry (structure (cmd-code word) (crnd-fcn address))) 
(deftype command-di spatch- table (array command-di spatch- table-entry «) ) 

:;; Stuff for display hacking 
(deftype font (structure 

(char-height word) 
.(char-width word) 

(raster-height word) 

(raster-width word) 

(basel ine word) 

(bytes (array byte 1))) -.Address will fit in a word 
defaul t-mode ref ) 
(deftype fcnt-ptr (pointer font)) 

(deftype window (structure 

(x-offset word) 
(y-offset word) 
(height word) 
(width word) 
(c:.'rsor-x word) 
(cursor-y word) 
(vsp word) ) 
defaul t-mode ref) 

(deftype sync-program (structure 

(words-per-I ine word) 
(video-f ieJd-l ines word) 
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defaui t-mode rcf ) 



(n-words word) 

(sync (array word 2000))) 



(deftype mpsc 
(structure 
(data byte) 
(« byte) 
(control byte)) 
volati ie t) 
(deftype mpsc-ptr (pointer itpsc)) 

(deftype dma-control ter 
(structure 

(kbd-addres3 byte) 
(Rbd-count byte) 
(« (array byte S)) 
(statusAcommand byte) 
(wr i te-request byte) 
(ur t te-single-masK byte) 
(ur i te-ffiode byte) 
(clear-f I ip-f Jop byte) 
(read-tetrpAinaster-clcar byte) 
(i I iegal byte) 
(ur i te-aM -masks byte)) 
voiati Ie t) 



;Harduare HPSC register 



;0 

;1 

;2-7 other devices 

;10 read-status / write conmand 

;11 software request feature 

;12 writ* single channel mask bit 

13 ur its channels mode bits 

14 clear byte pointer ff 

15 temp reg on read, master clear 

16 unused 

17 lou 4 bits write mask / channel 



(deftype tv-fcn (enumeration alu-setz alu-xor atu-seta)) 
; flacros for Machine &co. 

• flacro to create a SQ-CTL with the specified parts enabled. If parts - T» then 
: «SQ-CTL-UHILE -RUNNING* is used, otherwise, only the bits specified. Tasking 
; issues are dealt with in "URITE-SQ-CTL'*. 
(deflilmacro parts-enable (Areat p^rta) 
(if (and (• (length parts) 1) 
(cq (car parts) t)) 
'«sq-ctt-uhi le-running« 
(loop with parts-list - nil 
for part in parts 
do (if (neq part 'uir) 

(let ((enable (get * (ni I dp enable-dp sq enable-sq cnem enable-cmem 

trap enable-trap errhalt enable-errhal t 
task enable-task wp enabte-wp) part))) 
(if (null enable) (ferror nil "Illegal partname in -vA" parts)) 
(push 1 parts- list) (push enable parts-l ist) )) 
finally (return '(build sq-ctl , •parts-l ist) ))) ) 

(deflilmacro step-machine (parts) 

' (uri te-sq-ct I -to-step-machine (parts-enable * , (second parts)))) 

(deflilmacro spy-readlS (var) 

Mtet (((low word) (aref »var 8)) 

((high word) (aref ,var 1))) 
(dpb high «fol010 low))) 

(deflilmacro spy-writel6 (var vaO 

Mprogn (setf (aref ,var B) (byte (Idb #00010 ,val))) 

(setf (aref ,var 1) (byte (Idb ffalZlQ ,val)}))) 

;BUILD n I CRO INSTRUCT I ON with MO as Abus source 
;If there is an HC boards this reads the !0 MO 
(deflilmacro md-microinstruct ion (4rest fields) 

* (build microinstruction amra-sel 3 amra 2180 • .fields)) 

;;; Temporarly "bind" HC-CONTROL 

(deflilmacro wi th-special-mc-control (fields Abody body) 
'(let ( (saved-mc-control *last-mc-control*) ) 

(wr i te-mc-control (change mc-control saved-mc-control . .fields)) 
.(if body ' (progl (progn .©body) (uri te-mc-control saved-mc-control )) 
• (wr i te-rac-control saved-mc-control) )) ) 
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(deflilmacpo wi th-lbus-ecc-diag-mode (Sbody forma) 
•(progi (progn (mc-ecc-diag-mode true) 
.•forms) 
(mc-ecc-diag-mode fa[8e)))__ 

;;; Temper ar I y "bind" task 
(deflilmacro with-task (task 4body body) 
MIet (tsaved-task (read- task))) 

(disturb-sequencer) ; do this now. If rt happend during "body" ue would lose 
(wr i te-task-ignor ing-state-savtng , task) 

,{tf body *{ppogl (progn ,«body) (wri te-task-ignor rng-8tate-«aving saved-task)) 
• (wr i te-task- ignor ing-state-saving saved-task) ) ) ) 

(comment "Hack to read the EXT files into the end of the current buffer." 

(loop with ostream ■ zwei: (interva/-strcam-into-bp ( interval-last-bp *interval»)) 
for name in '("Print-things" "Global-var iabf es" "Fep-utiia" 

■Process") 
for pname ■ (fsimerge-pathname-defaui ts name (send zwei :«tnterva(* 'rpathname) "Ext") 
do (ui th-open-f i ie (i stream pname) 

(let» ((truename (send i stream 'ttrucname)) 

(creation (get (f s: f i (e-propert ies truename) ' :creat ion-date) ) 
(date (t ime:pr int-universal-t ime creation nit))) 

(format ostream "-^Zfi;;; ^A, created on --A." 

(send truename ' : str ing-for-pr int ing) date) 
(atream-copy-unti l-eof istrean ostream))))) 

;;; F: >liiiach>fep>pr tnt-things. ext . 13, created on 11/14/82 18:98:54, 
(EXTERNAL STREAn-PR I NT-NUnBER ( (N UORD) (BASE WORD) (STREAH STREAH) ) ) 
(EXTERNAL STREAH-PR I NT-OCTAL ( (N LONG) (STREAM STREAM))) 
(EXTERNAL STREAH-PR I NT-STRING ((STRING STRING) (STREAM STREAM))) 
(EXTERNAL STREAM-PRINT-SUBSTRING 

((STRING STRING) (FROM UORD) (TO UORD) (STREAM STREAM) ) ) 
(EXTERNAL STREAM-PRINT-BYTES ( (BP BYTE-PTR) (MAX-BYTES UORD) (STREAM STREAM))) 
(EXTERNAL 5TREAM-PRINT-U0RD 

((UCRD *BYTE-ARRAY-PTR) (UD UORD-DESCRIPTION) (STREAM STREAM) ) ) 
(EXTERNAL STREAM-PRINT-LBUS-UDRD ( (UD LBUS-UORO) (STREAM STREAM) ) ) 

(EXTERNAL SJREAM-PR I NT-BYTE- ARRAY ((ARRY tBYTE-ARRAY-PTR) (NBITS UORD) (STREAM STREAM))) 
(EXTERNAL STREAM-PRINT-MiCRDlNSTRUCTION 

((ARRY MICROINSTRUCTION MODE REF) (STREAM STREAM))) 

;;; F:>lm3ch>fep>global-var iab te3,ext.l2, created on 11/14/82 13:04:51. 

(DEFGLOBAL MEMORY-AS-BYTES (ARRAY BYTE 8) EXTERNAL T) 

CDEFGLOBAL MEMORY -AS -UORDS (ARRAY UDRD 6) EXTERNAL T) 

(DEFGLOBAL MEMORY-AS-LONGS (ARRAY LONG 0) EXTERNAL T) 

(DEFGLQBAL MEMORY-AS-SLONGS (ARRAY SLONG 0) EXTERNAL T) 

(DEFGLOBAL LBUS-MAP (ARRAY LBUS-MAP-SLOT 37E) EXTERNAL T) 

(DEFGLOBAL LBUS-DATA (ARRAY LBUS-DATA-PAGE 276) EXTERNAL T) 

(DEFGLOBAL QUOTE-T LBUS-UORD EXTERNAL T) 

(DEFGLOBAL QUOTE-NIL LBUS-UORD EXTERNAL T) 

(DEFGLOBAL REMOTE-CQNSOLE-LBUS-MAP-SLOT LBUS-MAP-SLOT EXTERNAL T) 

(DEFGLOBAL REMOTE-CONSOLE-LBUS-DATA-PAGE LBUS-DATA-PAGE EXTERNAL T) 

(DEFGLOBAL LBUS-MAP-SLOT UORD EXTERNAL T) 

(DEFGLOBAL BOOT-STATUS BOOT-STATUS EXTERNAL T) 

(DEFGLOBAL LOAD-MAP-ARRAY LOAD-MAP -ARRAY EXTERNAL T) 

(DEFGLOBAL INITIAL -MAP -ARRAY LOAD-MAP-ARRAY EXTERNAL T) 

(DEFGLOBAL CURRENT-PROCESS PROCESS EXTERNAL T) 

(DEFGLOBAL STANDARD- INPUT STREAM EXTERNAL T) 

(DEFGLOBAL STANDARD-OUTPUT STREAM EXTERNAL T) 

(DEFGLOBAL TERMINAL-IO STREAM EXTERNAL T) 

(DEFGLOBAL DEBUG- 10 STREAM EXTERNAL T) 

(DEFGLOBAL DRIVER-TABLE (ARRAY GENERAL-DRIVER N-GENERAL-DRI VERS) EXTEBKAL T) 

(DEFGLGBAL NuriEER-OF-AL I VE-ETHERNET- INTERFACES UORD EXTERNAL T) 

(DEFGLOBAL NUMBER-OF -ALIVE-CHAOS- INTERFACES UORD EXTERNAL T) 

(DEFGLOBAL EA-TABLE (ARRAY ETHERNET-ASSOCIATJON-ENTRY 12) EXTERNAL T) " 

(DEFGLOBAL ET-TA3LE (ARRAY ETHERNET-TRANSLATION-ENTRY 3B) EXTERNAL T) 

(DEFGLOBAL NUMEER-OF-ETHERNET-TRANSLATIONS UORD EXTERNAL T) 

(DEFGLOBAL NUM3ER-0F-ETHER\'ET-PROTDC0LS UORD EXTERNAL T) 

(DEFGLOBAL «I03-B0AR0-NUnBER* BYTE EXTERNAL T) 

(DEFGLOBAL *I OB-BOARD-BASE* LONG EXTERNAL T) 
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(DEFGLOBAL «LAST-FEP-READ-DISK-STATUS« LONG EXTERNAL T) 
(DEFGLOSAL DIStC-PAGE-LlST DISK-PAGE EXTERNAL T) 
(DEFGLOBAL JUNX-EH EVENT-HASX EXTERNAL T) 
(DEFGLOBAL JUNK LONG EXTERNAL T) 
(CEFGLCBAL TIHE CLOCK-VALUE EXTERNAL T) 



;;; F: > lmach>fep>f ep-ut i t 8.EXT.22, created on 11/17/82 88:03:04, 

(EXTERNAL (READ-I03-REG LONG) ((REG LONG))) 

URITE-IOB-REG ((REG LONG) (VAL LONG))) 
(READ-LEUS-LONG LONG) ( (ADDR LONG))) 
(REAO-LBUS LBUS-UORD) ( (AODR LONG))) 
URITE-LDUS-LONG ((ADDR LONG) (DATUH LONG) ) ) 
URITE-LBUS ((AODR LONG) (LBU LBUS-UORD) ^ ^ 



(EXTERNAL 
(EXTERNAL 
(EXTERNAL 
(EXTEFNAL 
(EXTERNAL 
(EXTERNAL 
(EXTERNAL 
(EXTERNAL 
(EXTERNAL 
(EXTERNAL 
(EXTERNAL 

(EXTERNAL 
(EXTERNAL 
(EXTERNAL 
(EXTERNAL 
(EXTERNAL 



(LISP-NULL BOOLE) ((VAL LBUS-UORD))) 

(INSERT-ODO-PARITY LONG) ((VAL LONG) (f^ITS LONG) ) ) 

PUT-ODD-PARITY.ON-UUORD ( (UUDRD fllCROINSTRUCTION HODE REF))) 

(EXTRACT-FIELD UORO) ( (P UORD) (S WORD) (ARRY «BYTE-ARRAY-PTR) ) ) 

INSERT-FIELD ((PUORD) (S UORD) (ARRY «BYTE-ARRAY-PTR) (BYTE LONG))) 

INSERT-UUORD-FIELD 

((PUORD) (S UORD) (UUORD n I CRD INSTRUCT I O: J MODE REF) (BYTE LONG))) 

URITE-VnEH ((ADR LONG) (VAL LBUS-UORD) ) ) 

URITE-VnEH-LONG ((AORLONG) (VAL LONG))) 

URITE-AHEn-LONG ( (AOR LONG) fVAL LONG))) 

(READ-VHEfl LBUS-UORD) ((ADR LONG! 1) 

(READ-AriEn-LONG LONG) ((ADR LONG))) 



;:; F:>lmach>fep>process.cxt.l0, created on 11/13/82 15:27:24. 
(DEFGLOBAL ONCE -PER -SCHEDULER -FUNCTIONS -QUEUE (ARRAY LONG 24) EXTERNAL T) 
(DEFGLOBAL ALL -PROCESSES PROCESS EXTERNAL T) 
(DEFGLOBAL OPSFQ- ACTIVE -LENGTH UORD EXTERNAL T) 
(DEFGLOBAL CURRENT -ONCE -PER -SCHEDULER -FUNCTION LONG EXTERNAL T) 
(DEFGLOBAL IN-THE-SCHEDULER-P BOOLE EXTERNAL T) 
(DEFGLOBAL LAST -RESTOREO-USER-STACK-PO INTER LONG EXTERNAL T) 
(DEFGLOBAL BAD-PROCESS-STATES LONG EXTERNAL T) 
(DEFGLOBAL SAVEO-SCHEDULER-STACK -POINTER LONG EXTERNAL T) 
(EXTERNAL INIT-PRDCESSES NIL) 
(EXTERNAL (PROCESS-RUN-FUNCTION-AUX PROCESS) 
((NAHE STRING) (FUNCTION LONG) 
__ (NUHARGS UORD) 

(ARGl LONG) 
(ARG2 LONG) 
(ARG3 LONG) 
(ARG4 LONG))) 
(EXTERNAL PROCESS-RUN-FUfCTION-UALL NIL) 
(EXTERNAL DESTROY-PROCESS ( (P PROCESS) ) ) 
(EXTERNAL LOGOUT NIL) 

(EXTERNAL ADD-ONCE-PER-SCHEDULER-FUNCTIDN ( (NEU-FUN LONG))) 
(EXTERNAL ONCE-PER-SCHEDULER-FUNCTIONS NIL) 
(EXTERNAL DESCHEDULE NIL) 

(EXTERNAL DESCHEDULE- INTERNAL ((NEU-STATE PROCESS-STATE))) 
(EXTERNAL PROCESS-UAIT-0 ( (UHOSTATE STRING) (FUNCTION LONG))) 

(EXTERNAL PR0CES5-UAIT-1 ( (UHOSTATE STRING) (FUNCTION LONG) (FLUSH-ARG-1 LONG))) 
(EXTERNAL PROCESS-UAIT-2 

((UHOSTATE STRING) (FUNCTION LONG) (FLUSH-ARG-1 LONG) (FLUSH-ARG-2 LONG))) 
(EXTERNAL PROCESS-UAIT-3 

((UHOSTATE STRING) (FUNCTION LONG) 

(FLUSH-ARG-1 LONG) 
CFLUSH-ARG-2 LONG) 
(FLUSH-ARG-3 LONG))) 



(EXTERNAL PROCESS-UAIT-4 

((UHOSTATE STRING) 



(EXTERNAL (PROCESS-FUJCALL 

(EXTERNAL (PROCESS-FUNCALL-1 BOOLE) 

(EXTERNAL (PROCESS-FUNCALL-2 BOOLE) 

(EXTERNAL (PROCESS-FUNCALL-3 BOOLE) 

(EXTERNAL (PROCESS. FUNCALL -4 BOOLEJ 



(FUNCTION LONG) 
(FLU5H-ARG-1 LONG) 
(FLUSH-ARG-2 LONG) 
(FLUSH-ARG-3 LONG) 
(FLUSH-ARG-4 LONG))) 
BOOLE) NIL) 

NIL) 

NIL) 

NIL) 

NIL) 
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(EXTERNAL PR0CESS-5TART-e NIL) 

(EXTERNAL PR0CE5S-START-I NIL) 

(EXTERtJAL PR0CE5S-START-2 NIL) 

(EXTERNAL PROCESS-START-3 NIL) 

(EXTERNAL PR0CESS-START-.4 NIL) 

(EXTERNAL SCHEDULER NIL) 

(EXTERNAL SUAP-BINDING-LIST-VALUES ( (BB BIND-BLOCO)) 

(EXTERNAL SUAP-BIND-BLOCK-VALUE ((SB BIND-BLOCO)) 

(EXTERNAL PROCESS-SLEEP ((INTERVAL LONG))) 

(EXTERNAL (PROCESS-SLEEP! BOOLE) ((FINAL-TIHE LONG))) 



;;;-*- Mode: LH; Package:Ltl; BaserS.; Lowercase: T -*- 

(include "Types-and-aacros") 

; Reference section 2.5 in Knuth 

; FREE BLOCKS: 



816 



1 N/2 (size) 


t 


1 forward 


1 ink 


1 backward 


link 


1 N - 4 

1 longs 

1 --... -,.—. 1 


1 N/2 (size) 


1 e 



ALLOCATED BLOCKS 



"N/2 (size) 



I 1 I 



N - 3 1 
al located longs | 
I 
-I 



process ID 



N/2 (size) I 1 I 
1 — I 



;;; allocated, not implemented 



;;; note: N/2 catenated with the flag bit gives N or N+1 

(defgiobai free-storage (array long 0) psect nil address 8) 
(defvar fsm-avai I able-header long 0) 
(defvar fsm-iou-address-from-ini t long 0) 
(defvar fsm-high-address-from-ini t Iong0) 
(defvar f sm-attempted-bad-frees long 0) 

(def li Imacro free-sto (idx) Maref free-storage ,idx}) 

(def ! i tmacro fsm-size (idx) '(free-sto ,rdx)) 

(def li imacro fsm-fud (idx) '(free-sto (+ Jdx 1))) 

(deflilmacro fsm-bck (idx) Mfree-sto (+ ,idx2))) 

(deftilmacro fsm-top (idx) * (+ ,idx (fsm-size ,idx))) 

(def I i Imacro fsm-mark! (idx) Mincf (free-sto ,tdx))) 

(defli Imacro fsm-unmarki (idx) Mdecf (free-sto ,idx))) 

(def li Imacro fsm-in-use? (idx) * (oddp (free-sto ,idx))) 
(defli Imacro fsm-free? (idx) * (evenp (free-sto ,idx))) 
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(defun fam-init ((low long) (high long)) 
(oetq fsm-attempted-bad-frees 0) 
(setq low (Ishr (+ low 3) 2) 

high (Ishr high 2)) 
(setq low (logand (1+ low) -2) 

high (logand high -2)) -these HUST be even 

(loop with (repo long) » B 

for (idx long) upfpom low below high 

do (setf (free-sto idx) zero)) 
(setq fsm*avai I able-header low) 
(setf (free-sto (+ low 3)) -1) 
. (setjf_lf'"ee-sto (- high D) -1) 

(setf (free-sto (. high 2)) -1) ' -aluays allocate in double longs 
(setq tow U tow 4) ^ 

high (- high 2)) 
(setq fsn-low-address-froB-init low) -yes, put it here 
(setq fsm-high-address-from-ini t high) 
(setf (fsffi-size low) (- high low)) 
(setf (free-sto (1- high)) (- high low)) 
(setf (fsm-fwd fsm-avai 1 able-header) low) 
(setf (fsm-bck fsm-avai taole-header) low) 
(setf (fsm-fwd tow) fsm-avai table-header) 
(setf (fsm-bck lew) fsm-avai lable-header) 

(defun (fsm-al locate long) ((size long)) 
(i f (minusp size) 
(long 0) 
(setq size (logand (Ishr (+ size 4_2 3) 2) -2)) 

(loop for (maybe iong) • (fem-fwd fsm-avai table-header) then (fsm-fwd maybe) 
when (■ Maybe fsm-avai lable-header) 
return. ( long 0) 
when (and (fsm-free? maybe) 

iz (fern-size maybe) size)) 
return 

(IshI (l-f (let ((maybe-size (fsm-size maybe)) 
(maybe-top (fsm-top maybe))) 
(if (> maybe-size (+ size 10.)) 
;; divide current block 
— (let ((ret-idx (- maybe-top size)) 

(neu-maybe-size (- maybe-size size))) 
(setf (fsm-size maybe) new-maybe-size) 
(setf (free-sto (1- ret-idx)) ncu-maybe-size) 
(setf (fsm-size ret-idx) (1+ size)) 
(eetf (free-sto (1- maybe-top)) (1+ size)) 
ret-idx) 
;; use entire block 
(fsm-mark! maybe) 
(fsm-mark! (1- maybe- top)) 

(setf (fsm-fwd (fsm-bck maybe)) (fsm-fwd maybe)) 
(setf (fsm-bck (fsm-fwd maybe)) (fsm-bck maybe)) 
maybe) ) ) 
2)))) 

(defun fsm-free ((old long)) 
(setq old (1- (Ishr old 2))) 
(i f (fsm-free? old) 

(incf fsm-attempted-bad-frees) 
(fsm-unmark! old) 
;; check lower region 
(if (fsm-free? (1- old)) 

(setq old (let* ((lower (- old (free-sto (1- old)))) 
(lower-fwd (fsm-fwd lower)) 
(lower-bck (fsm-bck lower))) 
(setf (fsm-fwd lower-bck) lower-fwd) 
(setf (fsm-bck lower-fwd) lower-bck) 

(setf (fsm-size lower) (+ (fsm-size lower) (fsm-size old))) 
lower))) 
: ; check upper 
(let ((upper (fsm-top old))) 
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(i f (f sm-free? upper) 

(let* ((upper-fud (fsm-fwd upper)) 
(upper-bck (fsm-bck upper))) 
(setf (fsm-fwd upper-bck) upper-fwd) 
(setf (fsm-bck upper-fud) upper-bck) 

(setf (fsm-sire old) (+ (fsm-size old) (fsm-size upper)))))) 
;; link it on to the fron of the available list 
(setf (fpee-sto (1- (fsm-top old))) (fsm-size old)) 
(setf (fsm-fwd old) (fsm-fwd fsm-avai I able-header) ) 
(setf (fsm-bck old) fsm-avai lable-header) 
(setf (fsm-bck (fsm-fwd fsm-avai lable-header)) old) 
(setf (fsm-fwd fsm-avai 1 able-header) old))) 
i(f-bdlc (progn 

(include "Types-and-aacros") 

(defun fsm-report-state 

(format t "^XReporting fr^e storage state -#^1") 
(format t "^tFSn-AVA I LABLE-HEADER is -vO i-I" 

(Ishl fsm-avai lable-header 2)) 
(format t "-XLOU is -0. HIGH is -0" 

(Ishl fsm-Iow-address-from-ini t 2) 
(Ishl fsm-high-address-from-init 2)) 
(format t "^XFrce blocks pool ^P) ...... 

(loop for (next long) - (fsm-fwd fsm-avai lable-header) then (fsm-fwd next) 
until (- next fsm-avai lable-header) 
do (progn (format t "^X-^l") 

(format t " Block at -^t linkages -^P (Ishl next 2)) 
(if (fsm-in-use? next) 

(format t "-I HELP!!! This block thinks it's *m use,")) 
(fsm-report-block-l inkages next) 
)) 
(format t "-XChaining through memory -mtP) 
(loop for (addr long) - fsm-Iow-address-from-ini t 
then (+ addr (fsm-size addr) 

{]f (fsB-in-use? addr) (long -1) Z)) 

unti 1 

(> addr fsm-high-addres9-from-»nl t) 

do-(progn (format t "-vX-^^I Start- ^. Size: --0, Top: ^" 
(Ishl addr 2) 
(Ishl (fsm-size addr) 2) 

(Ishl (+ addr (logand (fsm-size addr) -2)) 2)) 
(if (fsm-in-use? addr) 

(format t "*t It is in use.") 
(format t "*I It is free; linkages -^'vP) 
(fsm-report-block-l inkages addr))) 
finally 
(if (> addr fsm-high-address-frcm-tni t) 

(format t "^tFree storage did not end at the top."))) 
(format t "-^XDone.") 
) 

(defun fsm-report-block-l inkages ((block long)) 
(let ((top (logand (fsm-top block) -2))) 

(format t "^-t 8ize(b) fwd(b) bck(b) top-1 (b) top: *0 ^ ~0 ^ ^" 
(Ishl (fsm-size block) 2) 
(Ish! (fsm-fwd block) 2) 
(Ishl (fsm-bck block) 2) 
(Ishl (free-sto (1- top)) 2) 
(ishl top 2)))) 

) 

.;;.ii:. Mode: Li I; PackageiLiI; BaaesS.; Lowercase: T -*- 

(include "Types-and-macros") 

(externa! (fsm-al locate long) ((size long))) 
(external fsm-free ((old Jong))) 



4,887,235 
821 ^^ 822 

(defun (make-string string) ((size word)) 
(let ((string (temporarg 

(coerce string (fsm-aMocate 

(+ size (type-size string-type-header)))) 
(alloc string size JV* fsm-al locate)) ) ) 
(i f (not (nul 1 string)) 

(progn (setf (constant-string? string) fatse) 
(setf (string-length string) size) 
(setf (string-size string) size))) 
string) ) 

(defun return-string ((string string)) 

(if (and (not (nul I string)) (not (constant-string? string))) 
(temporary (fsm-free (coerce long string)) 

(fr ee s trin g stri ng tf * f sm- f r ee ) ) ) ) 
(defun (substring string) ((string string) (from word) (to uord) ) 
(sctq to (if (- to ENTIRE-STRING) 

(string-length string) 
(min to (string-length string)))) 
(let ((new-string (Mke-str ing (- to from)))) 
(loop for (new-idx uord) upfroR Q 

and (old-idx word) upfrom from below to 
do (setf (aref (str tng-bytes new-string) new-idx) 
(aref (string-bytes string) old-idx))) 
neu-string)) 

(defun (substring-after-char string) ((char byte) (string string)) 
(let (((idx uord) (str ing-search-char char string 8 ENTIRE-STRING))) 
(If (- idx STRING-SEARCH-FAILED) 

(temporary NULL-string (cstring "")) 
(substring string (1+ idx) ENTIRE-STRING)))) 

(defun (string-search-char word) ((char byte) (string string) 

(from uord) (to uord)) 
(Xstring-search-char char string from (if (• to ENTIRE-STRING) 

(str ing- length string) 
(■in to (str ing- length string))))) 

(defun (strrng-reverse-search-char uord) ((char byte) (string string) 

(from word) (to uord)) 
(setq from (if (■ from ent t re-»tr ing) 
(string-length string) 
(■in (string-length string) from))) 
(loop for (idx uord) dounfrom (1- from) to to 

uhen (- char (aref (string-bytes string) idx)) 

return idx 

finally (return STRING-SEARCH-FAILED))) 

(defun (str ing-search-not-char uord) ((char byte) (string string) 

(from uord) (to word)) 
(setq to (if (- to ENTIRE-STRING) 

(string-length string) 
(min to (string-length string)))) 
(loop for (idx word) upfrom from below to 

when (^ char (aref (string-bytes string) idx)) 

return idx 

finally (return STRING-SEARCH-FAILED))) 

(defun (str ing-rcverse-search-not-char uord) ((char byte) (string string) 

(from uord) (to uord)) 
(setq from (if (- from ENTIRE-STRING) 
(str ing- length string) 
(min (str ing- length string) from) ) ) 
(loop for (idx uord) downfrom (1- from) to to 

when (i« char (aref (string-bytes string) idx)) 

return idx 

finally (return STRING-SEARCH-FAILED))) 

(defun (string-search uord) ((key string} (string string) 

(from word) (to word)) 
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(setq to (- (If (- to ENTIRE-STRING) 

(string- length string) 
(min to (string- length string))) 
(string-length key) ) ) 
(if (< from to) 

(loop with (key-len word) « (string-length key) 

with (chl byte) « (aref (string-bytes key) 8) 
for (from uord) ■ (tistr i ng-search-char chl string from to) 
when (. from STRING-SEARCH-FAILED) 
return from 

when (Xstr ing-equal keg string from key- ten) 
return from 
do ( incf from) 
) 
STRING-SEARCH-FAILED)) 

(defun (Istring-search-char uord) ((char byte) (string string) 

(from uord) (to word)) 
(loop with (char byte) ■ char 
wi th (bp byte-ptr) 

- (make-pointer byte-ptr (aref (string-bytes string) from)) 
for (i word) upfrcm from beiou to 
when (■ char abp) 
return i 

do (ptr-incf bp byte-ptr (type-size byte)) 
finally (return STRING-SEARCH-FAILED))) 

(defun (Xstring-equa! boole) ((key string) (keybeg uord) 

(string string) (strbeg word) 
(key I en word) ) 
(loop repeat key ten 

with (keyptr byte-ptr) 

- (make-pointer byte-ptr (aref (string-bytes key) keybeg)) 
with (strptr byte-ptr) 

« (make-pointer byte-ptr (aref (string-bytes string) strbeg)) 
always (• •keyptr •strptr) 

do (ptr-incf keyptr byte-ptr (type-size byte)) 
(ptr-incf strptr byte-ptr (type-size byte)) 
J) 

(defun (string- to-based-number word) (^string string) (from word) (to uord) 

(base uord) ) 
(setq to (if (-to ENTIRE-STRING) 

(string-length string) 
(min to (string-length string)))) 
(loop with (ans word) « 2 

for (i uord) upfrom from below to 

do (setq ans (+ (« ans base) (aref (string-bytes string) i) i- ff/B)ll 

final ly (return ans) )) 



;;;-*- Hode: Li I; Package:Lit; BastiS.; Lowercase: T -«- 

(include "Types-and-macros") 

(eKternat (fsm-ai locate long) ((size long))) 
(external fsm-free ((old long))) 

(defvar once-per-scheduter-funct rons-queue (array long 20.) ()) 

(defvar&ini tfun ini t-processes 
current-process NULL-process ; means defined elsewhere 

all-processes process NULL-process 
opsfq-active- length uord 
curr en t-once-per -scheduler -function long 
in-the-scheduler-p boole false 
1 as t-restored-user-s tack-pointer long 
bad-process-states long 
) 

(defun (process-run-funct ion-aux process) ((name string) 

(function long) (numargs word) 
(argl long) (arg2 long) 
(argS long) (arg4 long)) 
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{let {(p (coerce process (fsm-al locate (+ (type-size process-type-header) 

(« 258. 4)))))) 
(if (nul I p) 

P 
(let (((sp word) 253.) 
((aS long))) 
(sctf (aref (process-stack p) (1- sp) ) 

)!f*process-run-funct ion-ual I ); simulate* • . 
(setq sp (1- sp)) ;...a cat I 

(setq sp (1- sp)) ;simulate.., 

(setq aS (coerce long (make-pointer long-ptr (aref (process-stack p) sp)))) 
(setq sp (- sp 15.)) ;-..a link a6,«-15.«4 

(setf (aref (process-stack p) (+ sp 14.)) aS) :8iBulate Riovem #377777, (a/) 

(set-fields p 

saved-stack-ptr (coerce long (make-pointer tong-ptr 

(aref (process-stack p) cp) ) ) 
process-name name 
ini ttal -function function 
process-state runnable 
whostate "Uait initial run." 

last-whostate NULL-string 
flush-routine (select numargs 

(0 «fproce3s-start-8) 
(1 #'process-start-l) 
(2 #*process-start-2) 
(3 #'process-start-3) 
(4 #• process-star t-4)) 
real -flush-rout ine function 
f lush-arg-1 argl 
f lush-arg-2 arg2 
fJush-arg-3 arg3 
f iush-arg-4 arg4 
b i nd i ng- list NULL-b i nd-b I ock 
) 
(setf (prev-process-l ink p) NULL -process) 
(if (not (null all-processes)) 

(setf (prev-process-l ink alt-processes) p)) 
(setf (next-process-link p) all-processes) 
(seLq al 1 -processes p) 
p)))) 

(riefun process-run-funct ion-ual 1 

(funcal I (flush-routine current-process)) 
( logout) ) 

(defun destroy-proce33 ((p process)) 
(fsm-iree (coerce longp))) 

(defun logout . *\^ 

(deschcduie- internal loggmg-out) ) 

Cincf opsfq-active-length)> 

do (funcal 1 (setq ^^^J/^^^^^^^^^^^ D)) 

finally (setq current-once-per-scheduler-function 8) 

)) . _ 

;;; «ystem-dependeint-context-»ui tch pushes all current regs on the 

;;: stack, then saves the stack auay in the pointer provided for 

;:: stashing, then sets the stack to neu stack value, pops regs (off 

;;: of that stack) and returns. 

(externa! system-dependent-context-switch ((new-sp long) (slot-for-old long-ptr))) 

(deftype pcinter-to-procecs (pointer process)) 

(defva*- savcd-scheduler-stack-pointer long -1) 
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(defun descheduie 

(deschedule-internal punnable)) 

(def'jn descheduie- internal ((neu-state process-state)) 
{setf (process-state current-process) neu-state) 
(syste«-dependent-context-5W( tch 
saved-schedu I er-s tack-pointer 

<«ake-po inter long-ptr (saved-stack-ptr current-process))) 
) 

IdeflilBacro defprocess-uai t-funct ions (ignore) 
(iccp for (fun flush-routine this starter) 

in • ( (process-uai t-3 process-funcat 1-8 flush-arg-0 process-start-0) 
(process-wai t-1 process-funcall-1 fIush-arg-1 process-start-l) 
(process-uai t-2 process-funcal t-2 flush-arg-2 process-star t-2) 
(process-uai t-3 procese-funcal t-3 flush-arg-3 process-start-3) 
(process-wai t-4 process-funcaM-4 flush-arg-4 process-start-4) ) 
as args ■ •{) then *(,«args (,this long)) 
as sets - '() then '(.•sets (setf (,this self) .this)) 
as cals « M) then M, teals (.this self)) 

collect. Mdcfun , f un ((whostate string) (function long) .•args) 
(let ((self current-process)) 

(setf (uhostate current-process) uhostate) 
,«sets 

(setf (real-flush-routine self) function) 
(setf (flush-routine self) )!?', f iush-rout ine) 
(deschedule-internal uaiting))) 
into process-uai ts 

collect '(defun (.flush-routine boote) 
(let (((retval booie)) 

(setf current-process)) 
(funcall (real-f tush-routine setf) 

(make-pointer boole-ptr retval) 
.•cals) 
retvat)) 
into f lush-rout ines 
collect Mdefun .starter 

(let ((self current-process)) 
_ (funcall (real-f lush-routine set f) .•cats))) 
into starters 
finally (return * (progn .•process-waits .©f tush-rout ines .•starters)))) 

(def process-uai t-funct ions thi s-arg-here-so-zmacs-wont-barf-uhen-reading-f i te) 

(defun scheduler 

(setq in-the-scheduier-p true) 

<setq current-process N'JLL-process) 

(setq TIHE 8) 

( I cop do 

(once-per-scheduler- functions) 

(loop for (p process) - all-processes then next-p 

unti I (nut I p) 

as (next-p process) « (next-process-I ink p) 

if (select (process-state p) 

(runnable true) 

(uai ting ( let-global ly ((current-process p)) 

(funcal t-for-value (boole boole-ptr) (flush-routine p)))) 

(stopped false) 

(otherwise (incf bad-process-states) 

(setf (process-state p) stopped) 
fal se) ) 

do (when (« (process-state p) uaiting) 

(setf (last-uhostate p) (uhostate p))) 

(setf (process-state p) running) 

( tet»-global ly ( (current-process p) 

(in-the-scheduler-p false)) 

(swap-bindtng-l ist-vaiues (bind'mg-l i st p) ) 

(setq tast-restored-user-stack-pointer (saved-stack-ptr p)) 

(system-dependent-context-sui tch 

(saved-stack-ptr p) 

(make-pointer long-ptr saved-schedu ler-stack-poi nterl ) 
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(swap-binding-! ist-values (binding-list p))) 
(if (« (process-State p) logging-out) 

(ppogn (if (null (prev-ppocess-l ink p)) 
(setq all-processes next-p) 
(setf (next -process- 1 ink (prev-process-l ink p)) 
next-p)) 
(if (not (null next-p)) 

(setf (prev-process-l ink next-p) 
(prev-process-t ink p))) 
(destroy-process p))) 
) 
(incf TinE) 
)) 

(defun 8uap-bindtng-i i st-vaiues ((bb bind-b(ock)) 
( loop unt i I (nul I bb) 

do (swap-bind-b lock-value bb) 

(setq bb (next-bind-block bb) ) ) ) 

(defun suap-bind-b lock-value ( (bb bind-block)) 
(let ((ptr (ptr bb) ) 

(val-bb (val bb))) 
(select (size bb) 

(1 (setf (val bb) (long •(coerce byte-ptr ptr))) 

(setf •(coerce byte-ptr ptr) (byte vat-bb))) 
(2 (setf (val bb) (long •(coerce uord-ptr ptr))) 

(setf •(coerce uord-ptr ptr) (uord val-bb))) 
(otherwise (setf (val bb) (long •(coerce long-ptr ptr))) 

(setf •(coerce tong-ptr ptr) (long val-bb))) 
))) 

(defun process-sleep ((interval long)) 

(process-uait (cstrtng "Sleep") ^f'process-sleepl (+ (coerce long TIHE) interval))) 
(defun (process-sleepl booie) ((final-time long)) 

ii (coerce long TinE) final-time)) 

;;;-»- Mode: Li I; Package:Lil; 6ase:8.; Lowercase: T -»- 

(include "Types-and-wacros") 

(externals ((fsm-aUocate long) long) 
(fsm-free long) 

) 

(defun i nit-streams 

(setq terminal-io NULL-strcam) 
(setq standard-output NULL-strcam) 
(setq standard- input NULL-stream) 
(setq debug-io NULL-stream) 
) 

(defun (al locate-stream stream) ((size long)) 

(let ((stream (coerce stream (fsm-allocate size)))) 
(unless (nul I stream) 
(set-fields stream 
x-pos 8 
y-pos 

for-tyo #' stream-no-operation-stand in 
for-tyi-eof #* stream-no-operation-stand in 
f or-ty i -no-hang tt* stream-no-operat i on-stand i n 
for-ciose ^' strcam-no-opcrat ion-standin 
for-terpr t-or-fresh-l ine #' stream-no-operat ion-standin 
)) 
stream) ) 

(defun return-stream ((stream stream)) 
(unless (nul I stream) 

(fsm-free (coerce long stream)))) 

(defun stream-no-operation-standin 
(let {((a byte))) 
(setq a 8))) 
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(defun stream-tyo ((char byte) (stream stream)) 
(unless (nu) I stream) 

(funcali (fop-tyo stream) stream char))) 

(defun (stream-tyi byte) ( (stream stream) ) 
(let (( (ignore boole))) 

(stream-tyl-eof ignore stream))) 

(defun (stream-kbd-tyi -no-hang boole) ((stream stream)) 
(i f (nul I stream) 
true 
(funcai t-for-v3lue (boole boole-ptr) (for-tyi-no-hang stream) stream))) 

(defun (stream-tyi-eof byte) ((eof-option boole mode ref) (stream stream)) 
(setq eof-option false) 
( i f (nul t stream) 

(progn (setq eof-option true) 
(byte -D) 
(funcai l-for-value (byte byte-ptr) (for-ty?-eof stream! 

stream (make-pointer boole-ptr eof-option)))) 

(defun stream-close ((stream stream)) 
(unless (null stream) 

(funcali (for-close stream) stream))) 

(defun stream-terpri ((stream stream)) 
(unless (nul I stream) 

(funcali (for-terpri-or-fresh-l rne stream) stream true))) 

(defun stream-fresh-l ine ( (stream stream) ) 
(unless (nul I stream) 

(funcali (for-terpri-or-fresh-I ine stream) stream false))) 

F:>lmach>fep>print-things.l 11 .10 Page 1 



:;:-«- Mode: Lit; PackagerLtl; Base:S.; Louercase: T -*- 

(include "Types-and-macros" "Fep-ut i Is.ext") 

(defun stream-print-number ( (n wcrd) (base word) (stream stream)) 
(if (< n 0) (prcgn (tyo Ui- stream) (setq n (- n) ) ) ) 
(let (((digit byte) (byte (\ n base))) 
((rest word) (// n base))) 
(if (* rest) (stream-print-number rest base stream)) 
(tyo (+ #/0 digit) stream))) 

(defun stream-print-octal ( (n long) (stream stream)) 
(loop with (print-p boole) • false 

for (i word) from (// 32. 3) downto 3 

do (let (((digit byte) (byte (iogand (Ishr n (» i 3)) 7)))) 
(cond ((or Kn 3 digit) print-p) 

(tyo {+ digit #/3) stream) 
(setq print-p true)))) 
finally (if (not print-p) (tyo UfZ stream)))) 

(defun stream-print-string ((string string) (stream stream)) 
(loop for (i wcrd) upfrom below (string-length string) 
do (tyo (aref (string-bytes string) i) stream))) 

(defun stream-print-substring ((string string) (from word) (to word) (stream stream)) 
(loop for (i word) upfrom from below to 

do (tyo (aref (string-bytes string) i) stream))) 

(defun stream-print-bytes ( (bp byte-ptr) (max-bytes word) (stream stream)) 
(loop with (bp byte-ptr) « bp 
repeat max-bytes 
as (char byte) « »bp 
do (ptr-incf bp byte-ptr (type-size byte)) 
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:unt i I (zerop char) 
do (tyo char stream) 

(defjn stream-print-word ((word *byte-arr3y-ptrl (wd word-description) (stream stream)) 
(loop initially (format stream "'^") 
uith (comma boole) » false 
for (i word) upfrom 

as (fd field-description) « (aref 9u6 i) 
until (null fd) 
as (start-bit word) - (pp fd) 
as (value long) ^ (loop uith (\ uord) • (\ start-bit S.) 

for (idx word) upfrom (// start-bit S.) 

as (byte byte) - (aref sword idx) 

for (value long) first (logand (long (Ishr byte \}) *fo377) 

then (+ value (IshI (logand (long byte) ^o277) IshD) 
for (ishi uord) first (- 8 \) then (+ IshI 8) 
when (> IshI (ss f d) ) 

return (logand value (- -1 (IshI -1 (iss fd))))) 
as (print-something boole) « faise 
as (value-name string) » NULL-string 
as (print-va/ue-in-octal boole) » false 
do (cond ((and (> value 0) (< value (n-value-natnes fd))) 
tsetq value-name (aref (value-names fd) value)) 
(unless (null value-name) (setq print-something true))) 
(T (setq print-something true) 

(setq print-value-in-octal true))) 
uhen print-something 
do (when comma (format stream *\ ")) 
(setq comma true) 

(when (print-name fd) (format stream "*A '* (name f d) ) ) 
(unless (null value-name) (format stream "^-A" value-name)) 
(when print-value-in-octal (format stream "^0" value)) 
)) 
;;; Internal types. Just to get the bit order correct, 
(deftype 48bits (array byte G)) 
(deftype p-48bits (pointer 48blt8)) 

(defun stream-print-f bus-word ((ud Ibus-word) {stream stream)) 
(let ({(arry 48bits)>) 

(loop for (i uord) belou 4 

for (v long) « (data wd) then (Ish v -8) 
do (setf (aref arry i) (byte (Idb tfo0010 v)))) 
(setf (aref arry 4) (byte (Idb (foSBlQ (ecc+high ud)))) 
(setf (aref arry 5) (byte (Idb nol^l^ (ecc+high wd)))) 
(stream-pr int-byte-array 

(coerce «byte-array-ptr (Bake-pointer p-48bits arry)) 44. stream))) 

;This takes a byte array and a bit count, and prints the low nbits of the byte 
; array as a single octal number. 

(defun stream-print-byte-array ((arry «byte-array-ptr) (npits word) (stream stream)) 
(let* ((numbcr-of-top-bits (V nbits 3)) 

(adjusted-nbi ts (- nbits number-of-top-bi ts) ) 

(top-bits (extract-field adjusted-nbi ts number-of-top-bi ts arry)) 
(print-reros false)) 
(unless (zerop top-bits) 

(stream-print-number top-bita 8 stream) 
(setq print-zeros true)) 
(loop for (i word) from (- adjusted-nbi ts 3) dounto 8 by 3 
for (field word) « (extract-field i 3 arry) 
do (unless (zerop field) (setq print-zeros true)) 

(if print-zeros (stream-print-number field 8. stream))))) 

(defun stream-pr int-iiicroinstruct ion ((arry microinstruction mode ref) (stream stream)) 
(stream-print-byte-array (coerce *byte-array-ptr (make-pointer microinstruct ion-ptr arry)) 

112. stream)) 
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F:>1mach>fep>globa1-variab1es,li1 .14 Page 1 

:;;-»- Mode: Li I; Pac*cage:L» I ; BaaerS.; Lowercase: T -«- 

( include "Tgpee-and-Rtacros") 

(defgiobal memory-as-bytes (array byte 0) psect absolute address B) 

(defgiobal memory-as-uords (array word 9) psect absolute address 0) 

(defgiobal memory-as- longs (array long 8) psect absolute address 0) 

(defgiobal memory-as-s longs (array slong 0) psect absolute address 0) 

(defgiobal Ibus-map (array Ibus-map-slot 254.) address ^ol774020 psect absolute! 
(defgiobal Ibus-data (array I bus-data-page 254.) address tfol000000 psect absolute) 

;;; These two are just here for speed (sigh.,.) 

(defgiobal retnote-console-lbus-map-slot Ibus-«ap-slot address #ol774000 psect absolute) 

(defgiobal remote-console- 1 bus-data-page I bus-data-page address #01000033 psect absolute) 

(defvar Ibus-map-slot word 1) jThls controls read-lbus «co. 

(defvar boot-status boot-status bs-no-boot-status) 

(defvar load-wap-array load-siap-array (make-null-pointer load-«ap-array) ) 
(defvar ini tial-«ap-array load-«ap-array (•ake-nul l-pointer load-map-array) ) 

(defvar quote-t Ibus-word ()> 
(defvar quote-ni I Ibus-word ()■) 

(defvar current-process process NLLL -process) 

(defvar standard- input stream NULL-stream) 
(defvar standard-output stream NULL-stream) 
(defvar terminal-io stream NULL-stream) 
(defvar debug- io stream NULL-stream) 

(defvar driver-table (array genera I -dr iver n-general-dr i vers) nil) 

(defvar number-of-a! i ve-ethernet-i*nterfaces word 0) 
(defvar number-of-a! ive-chaos-interfaces word 0) 

(defvar ea- table (array ethernet-associ at ion-entry 10.) nil) 
(defvar et-table (array ethernet-trans I at ion-entry 30.) nil) 

(defvar number-of-ethernet-translations word 0) 
(defvar number-of-ethernet-protocols word 0) 
(defvar Kciob-board-number* byte 10) 
(defvar «iob-board-base* long 10.19.) 

(defvar *last-fep-read-disk-statu8* long 0) 

(defvar di sk-page-l ist disk-page NULL-disk-page) 

(defvar junk-em event-mask 0) 

(defvar junk long 0) 

(defvar TIME clock-value 0) 

F:>lmach>fep>68K-context-sw1tch.68lc.l d.„« - 

rage i 

;:: -«- Mode: G8K; Package: Lil; Base: 8. -»- 

;;; (defun system-dependent-context-switch (new-stack pointer-for-old) ...} 

(■odule (system-dependent-context-switch psect code address 2000) 

system-dependent-contCKt-swi tch 

(words 04712G^.i* -15. 4)) .{link raS P^. i* -15. 4)) 

(moveml (t 077777} (• ra7) ) ; everything but _the_stack pp|nter 
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(fflovel (cO 10 raB) raS) ;ftecond arg: pointer for old stack 
(movcl ra7 (• ra9)) 

(movel (•□ 14 raS) ra7) tfirtt arg: 
' (movemi (• ra7) iX 877777)} 
iunlk raS) 
(rts} 
) 

F:>1mach>fep>network. 1 n ,4 Page 1 



;;;-«- Mode: Li I; PacKagerLlI; Base: 8.; Louercase: T -«- 

{include "Types-and-Kacros") 

(external (fsm-al locate long) ((size long}}) 
(external fsm-free ((old long))) 
(external return-string ( (s string)) ) 



Actual code 



(defun gpkt-copy-header ((old gpkt) (new gpkt)) 

(loop for (i word) upfrom 8 below (type-size gpkt-type-header) 
do (sctf (aref (gpkt-type-header-bytes new) i) 

(aref (gpkt- type-header-bytes old) i)))) 

(defun (al locate-gpkt gpkt) ((sire word)) 

(let ((pkt (temporary (coerce gpkt (fsm-at locate 

(+ sire (type-size gpkt-type-header) ) ) ) 
(alloc gpkt tf' fsm-al locate)))) 
(if (not (nu! I pkt)) 
(set-fields pkt 

gpkt-al iocated-size size 

gpkt-error-message NULL-string 

gpkt-xmi t-l ink NULL-gpkt 

gpkt-user-( ink NULL-gpkt 

— gpkt-on-a-user-l ist? false 

gpkt-on-an-xmi t-M st? false 

header -byte- format bf- interna I 

data-byte- format bf- interna I 

gpkt-receive-time TIME 
)) 
pkt)) 

(defun (make-error-gpkt gpkt) ((error-message string)) 
(let ((pkt (al locate-gpkt 8))) 
(if (nul I pkt) 

(return-string error-message) 
(setf (gpkt-error-messagc pkt) error-message)) 
pkt)) 

(defun return-gpkt ((pkt gpkt)) 
(unless (nul 1 pkt) 

(unless (null (gpkt-error-message pkt)) 

(return-string (gpkt-error-message pkt))) 
(fsm-free (coerce long pkt)))) 

(defun return-gpkt- if-not-on-a-user- I i St ((pkt gpkt)) 
(unless (nul I pkt) 

(if (gpkt-on-a-user-l ist? pkt) 

(setf (gpkt-on-an-xmi t-l ist? pkt) false) 
(return-gpkt pkt)))) 

(defun return-gpkt- if -not-on-an-xmit-l ist i tpkt gpkt)) 
(unless (nul I pkt) 

(if (gpkt-on-an-xmi t-n St? pkt) 

(setf (gpkt-on-a-user-list? pkt) false) 
(return-gpkt pkt)))) 
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(defun return-gpkt-l ist {(pkt gpkt)) 
(unless (nul I pkt) 

(loop as (next gpkt) - (gpkt-user- ! ink pkt) 
do (return-gpkt pkt) 
unti I (nul i (setq pkt next))))) 

(defun return-gpkt-Mst-if-not-on-an-xmit.t iet ((pkt gpkt)) 
(unless (nu! I pkt) 

(loop as (next gpkt) - (gpkt-user- 1 ink pkt) 

do (return-gpkt-i f-not-on-an-xmi t-I ist pkt) 
until (null (setq pkt next))))) 

(dcfun return-gpkt-xmit-l ist {(pkt gpkt)) 
(unless (nul I pkt) 

(loop as (next gpkt) - (gpkt-xml t-l ink pkt) 

do (peturn-gpkt-if-not-on-a-user-l rst pkt) 
unti 1 (nu( I (setq pkt next))))) 

(defun init-netuork {) 

{ i n 1 1 i a I i re-genera I -dP i vers) 

;; maybe more stuff ui I t go here tn the future 

) 

(defun initial ize-general-dri vers 

(loop for (i word) from 8 below n-general-dr i vers 

do (setf (aref driver-table i) NULL-general-dri ver)) 
(setq number-of-ali ve-ethernet-interfaces 8) 
(setq numter-of-al ive-chaos-interfaces 0)) 

(defun (create-general-dri ver genera I -dr iver) ((size word)) 

(let ({drv (temporary (coerce genera I -driver (fsm-al locate size)) 
(alloc genera I -driver #' fsm-a I locate) )) ) 
(if (not (nul I drv)) 
(progn 
U, ( loop for (field Ival) 

in * ((gdrv-xmi t-Iist MTLL-gpkt) 
(gdrv-xmi t-tai t MJLL-gpkt) 
_ (gdrv-current-output-pkt NULL-gpkt)) 

collect *{setf (.field drv) ,ival) into setfs 
finally (return * (progn .tsetfs))) 
(reset-netucrk-statistics drv) 
(cgd-clear-ethernet-f ields drv) 
(cgd-clcar-chaosnet-f icids drv))) 
drv 
)) 

(defun destroy-genera I -driver ((drv genera I -dr iver) ) 
;:; do some other things here too 
(fsm-free (coerce long drv))) 

(defun reset-network-statistics ((drv genera I -dr iver) ) 
(set-fields (gdrv-stat ist ics drv) 
packets-in 

packets-out 
packets-aborted 
packets-lost 
packets-crc-error 
packets-ram-error 
packets-bi tc-error 
packets-other-reject 
)) 

(defun f ini sh-generai-dr i ver (Cdrv genera l-dr iver) ) 
(fgd-f ini sh-et her net-fields drv) 
(f gd-f inlsh-chaosnet-f ie Ids drv) 
(loop for (i word) upfrom 0. 

until (null (aref driver-table i)) 
finally (setf (aref driver-table i) drv)) 
) 
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<defun cant-send-an-ethernet-pacKct ((drv genera I -driver) 

(pkt gpkt) 

(ethernet-address byte-ptr)) 
(return-gpkt-i f-not-on-a-user- I i 8t pKt)) 

(defun cgd-clear-etharnet-f ields ((drv genera 1 -dr iver) ) 

(setf (send-an-ethernet-packet drv) #*cant-send-an-ethernet-packet} ) 

(defun fgd-f 'mi sh-ethernet-f ields ((drv genera S-dr iver)) 

(if (» (send-an-ethernet-packet drv) ;tf'cant-send-an-ethernet-packet) 
( incf number-of-al ive-e theme t- inter faces) ) ) 

(defun cant-send-a-chaos-packet ((drv general -driver) 

(pkt gpkt) 

(chaos-address uord)) 
(return-gpkt-i f-not-on-a-user- 1 ist pkt) ) 

(defun cgd-clear-chaosnet-f ields ((drv genera I -dr i ver) ) 

(setf (send-a-chaos-packet drvl Jtf*cant-send-a-chaos-packet) ) 

(defun fgd-f inish-chaosnet-f tcfds ((drv gerrerai-dr 1 ver) ) 

(if (<« (send-a-chaos-packet drv) #*cant-send-a-chao5-packet) 
(incf number-of-ai ive-chaos- inter faces) )) 

(defun add-pkt-to-dr iver-queue ((pkt gpkt) (drv general-dr i ver) ) 
(setf (gpkt-xmit-link pkt) NULL-gpkt) 
(ui thou t- interrupts 

(if (null (gdrv-xmi t-tai i drv)) 

(setf (gdrv-jcmt t-I ist drv) pkt) 

(setf (gpkt-xmi t-l ink (gdrv-xmi t-tai I drv)) pkt)) 
(setf (gdrv-xmit-tail drv) pkt) 
(setf (gpkt-on-an-xmi t-t ist? p^t) true)) 
) 

;;; This does not 'declare* it off the xniit list. The driver rust 
;;; do an explicit (return-current-output-pkt drv) in order to 
;;; 'declare* it off the xmit list 

(defun (get-pk^t-from-dr iver-queue gpkt) ((drv general-dr iver)) 
(setf (gdrv-current-output-pkt drv) 
(wi thou t- interrupts 

(let ((pkt (gdrv-xmi t-l ist drv))) 
(unless (nul I pkt) 

(when (nut! (setf (gdrv-xmi t-l ist drv) (gpkt-xmi t-l ink pkt) ) ) 

(setf (gdrv-x«it-tai I drv) NULL-gpkt)) 
(setf (gpkt-xmi t-time pkt) TIME)) 
pkt)))} 

(defun return-current-output-pkt ((drv genera I -dri ver ) ) 
(unless (null (gdrv-current-output-pkt drv)) 

(return-gpkt-i f-not-on-a-user- I ist (gdrv-current-output-pkt drv)) 
(setf (gdrv-current-output-pkt drv) NULL-gpkt))) 

F:>lfflach>fcp>ethernet-conf ig.in .3 Page 1 



;;;-»- Dode: Li); Package:Lil; Base: 8.; Louercase: T -»- 

(include "Types-and-macros") 

(def I i Imacro defethernet-protocols (&rest forms) 
( ! OOP 

for n upfrom B 

for name in forms 

as specials « (intern (string-append "ETHER-TRANS-ADD- " name "-SPECIALS") 'Ml) 

and receiver - (intern (string-append "RECEIVE-" name "-PACKET-FROn-HARDUARE") 

•Ml) 
and protocol - (intern (str ing-append "ETHER-TYPEf " name) 'iil) 
and length » (intern (string-append "ETHER-LENGTHS" name) 'liD 
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and addr-ref - (intern (string-append name "-ADDRESS") *lii} 
col lect ' (progn (external .special s ()) 

(external , receiver ()}) 
into defs 

collect * (progn (setf (cae-protocol (aref ea-table ,n)) .protocol) 
(setf (eae-length (aref ea-table .n)) .length) 
(setf (eae-peceivep (aref ea-table ,n}) #'.peceivep) 
(setf (eae-pa-offset (apef ea-table ,n)} 

(- (stpucture-of fset ,addp-pef genepal-dpivep) 

(structure-offset gdpv-othep-ncp-f ields genepal-dPivcp) )) 
) 
into sctfs 
finally (return '(progn ,«defs 

(defun conf ig-ethernet 

(setq number-of-ethernet-tpanslat ions 0) 

.•setfs 

(setq numbep-of-ethernet-ppotocols ,n)))})) 

(defethepnet-ppotocols 
chaos 

;DOD-Internet 

;Xepox-PUP 

) 

;:;-»- node: Lit; Package:Li I ; Base: 8,; Lowepcase: T -«- 

(include "Types-and-nacpos") 
(include "network. EXT") 

(defvar »edebug* word 8) 

(-defun receive-ethernet-packet-from-harduape Hdrv genera 1 -dp ivep) 

ipKt gpkti 
(protocol word)) 
s(fdebug 189000 »edebug« "^XReceive ethernet packet from hardware...") 
(loop for (i word) upfrom below number-of-ethernet-protocols 
if (- protocol (eae-ppotocol (apef ea-table i))) 
do (funcall (eae-peceivep (apef ea-table i)) dpv pkt) 

(petupn) 
finaMy (if (• ppotocol ethep-typeladdpess-pesolut ion) 
(receive-addPes5-peso tut ion-packet dpv pkt) 
(netwopk-metep dPv packets-othep-pe ject) 
(peturn-gpkt pkt)))) 

(defun transmi t-ethepnet-packet ((dPv genepat-dpivep) 

(pkt gpkt) 
(ppotocol wopd) 

(eapb ethepnet-addpess-peso I ut i on-b I ock 
»ode pef)) 
:(fdebug 040008 «edebug« "-^I transmit ethepnet packet...") 
(let (((length wopd) (loop fop Ci wopd) 

upfpom 

be I ou nuDibep-of -ethernet-ppotoco I s 
when U ppotocol (eae-ppotocoI (apef ea-table i))) 
retupn (eae-length (apef ea-table i)) 
final ty (petupn 0)))} 
(if (zepop length) 

(petupn-gpkt-i f-not-on-a-usep- 1 ist pkt) 
(loop fop (j wopd) upfpom below numbep-of-ethepnet-tpans tat ions 
when (and (« ppotocol (ete-ppotocol (apef et-table j))) 
(loop fop (k word) upfrom below length 
always (« (aref (earb-bytes carb) k) 
(apef (eapb-bytes 

(ete-protoco I -address 
(aref et-table j))) 
k)))) 
do (ppogn (funcall (send-an-ethepnet-packet dPv) 
dPv pkt ppotocol 
(make-pointep 
ethepnet-addpess-ptp 
(ete-ethepnet-addpess (apef et-table j)))) 
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(return) ) 
finally (progn (return-gpkt-i f-not-on-a-user-l ist pkt) 
(requcst-ethernet-tpansiation 
dpv protocol length earb) ) ) ) ) ) 

(deftype ares-pkt (pointer ares-pkt-type auto-dcrcference t)) 
(deftype ares-pkt-type (structure (include gpkt-type-hcader 

preserve-order t) 

(ares-pkt-protocol word) 

(ares-pkt- length word) 

(ares-pkt-opcode word) 

(are»*pkt-sea cthernet-address-array-type) 

(ares-pkt-tea ethernet-address-array-type) 

(ares-pkt-*pa (array byte #• (+ 13. Id,))))) 

(defun recei ve-address-reso I ut ion-packet C (drv genera I -driver) (pkt gpkt)) 
; (fdebug 028009 »edebug« "^Xreceive address resolution packet...") 
; (when (bit-test 010000 »edebug») (show-addr-tran-pkt pkt)) 
(loop with (ares-pkt ares-pkt) • (coerce ares-pkt pkt) 

with (protocol word) » (ares-pkt-protocol ares-pkt) 
with (length word) « (etherword (ares-pkt-length ares-pkt)) 
for (i word) upfront below number-of-ethernet-protocol s 
when (and (« protocol (eae-protocol (aref ea-table i))) 
(loop repeat length 

for (j word) upfroo (eae-pa-of fset (aref ea-table i)) 
for (k word) upfront length 

always (• (aref (gdrv-other-ncp-f ields drv) ]) 
(aref (ares-pkt-«pa ares-pkt) k)))) 
do (network-nteter drv packets-in) 

(hand te-address-resolut ion-packet drv pkt protocol length) 
(return) 
finally (return-gpkt pkt))) 

(defun handle-address-resolution-packet ((drv genera I -driver) (pkt gpkt) 

(protocol word) (length word)) 
;(fdebug 004000 »edebug« "'^Xhandte address resolution packet") 
(let ((pkt (coerce ares-pkt pkt))) 

(loop for (i word) upfron below number-of-ethernet-translat ions 
unt'tl (and (» protocol (ete-protocol (aref et-table i))) 
(loop for (j word) upfront below length 
always (- (aref (earb-bytes 

(ete-protocol -address 
(aref et-table i))) j) 
(aref (ares-pkt-*pa pkt) j)))) 
finally 

(when (< i (array-length et-table)) 
;; ntaybe add new entry 
(if iz i number-of-ethernet-translat ions) 

(loop for (j word) upfront below length 
do (setf iaref (earb-bytes 

(ete-ppotoco I -address 
(aref ct-tabic I))) j) 
(aref (ares-pkt-«pa pkt) j)) 
final ly 

(setf (ete-protocol (aref et-tabie i)) protocol) 
( i ncf number-of-ethernet-trans I at i ons) 
)) 
;; reset ethernet addpess in case it changed !! 
(loop for (j word) upf rom 8 below 6 

do (eetf (aref (etc-ethcrnet-addpess (apef et-table i)) j) 
(apef (ares-pkt-sea pkt) j))))) 
(if (pi (apes-pkt-opcode pkt) ethep-apes-optpequest) 
(return-gpkt (coerce gpkt pkt)) 
(setf (ares-pkt-opcode pkt) ether-ares-optrepty) 
(setf (ares-pkt-tea pkt) (ares-pkt-sea pkt)) 
(setf •(make-pointer ethernet-address-ptr (ares-pkt-sea pkt)) 
•(coerce ethernet-address-ptr (make-pointer byte-ptr 

(aref (ethernet-address drv) 0) ) ) ) 
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(loop for (sender word) upfrom below length 
for (target word) upfrom length 
do (suapf (aref (ares-pkt-*pa pkt) target) 

(aref (ares-p*ct-«pa pkt) sender))) 
(funcall (send-an-ethernet-packet drv) 

dpv pkt (word ether-typelADDRESS-RESOLUTION) 
(make-pointer ethernet-address-ptr (arc3-pkt-tea pkt))) 
))) 

(defun show-addr-tran-pkt ((pkt gpkt)) 
(let ((pkt (coerce aree-pkt pkt))) 

(fopwat t "^XProtocolt ^0" (ares-pkt-ppotocol pkt)) 
(foraat t "-tfpora: <^,-rO,*Q,--0,^,^>,<" 
(aref (ares-pkt-sca pkt) 0) 
(aref (ares-pkt-sea pkt) 1) 
(aref (ares-pkt-sea pkt) 2) 
(aref (ares-pkt-sea pkt) 3) 
(aref (ares-pkt-sea pkt) 4) 
(aref (ares-pkt-sea pkt) 5)) 
(loop for (i word) upfrom below (etherword (ares-pkt- length pkt)) 
unless (zerop i) 
do (tyo «?/,) 

do (format t "--0" (aref (ar es-pkt-»:pa pkt) i))) 
(format t '>^Xlo: <'^,*0,*^,'*0,-^.'^>,<" 
(aref (arcs-pkt-tea pkt) 0) 
(aref (ares-pkt-tea pkt) 1) 
(aref (ares-pkt-tea pkt) 2) 
(aref (ares-pkt-tea pkt) 3) 
(aref (ares-pkt-tea pkt) 4) 
(aref (ares-pkt-tea pkt) 5)) 
(loop wtth (1 word) • (etherword (ares-pkt-length pkt)) 
repeat I 

for (i word) upfrom \ 
unless (* i i) 
do (tyo #/, ) 

do (format t "^O" (aref (ares-pkt-*pa pkt) i))) 
(format t %") 
)) 
(defun request-cthernet-translat ion ((drv general-driver) 

(protocol word) (length word) 
(earb ether net-address-reso I ut i on-b I ock 
mode ref)) 

:(fdebug 002000 «edebug« "-.^request ethernet translation") 

(let* ({pkt (coerce ares-pkt (at locate-gpkt (type-size ares-pkt-typs) ) ) ) 

(offset (loop for (i word! upfrom betou number-of-ethernet-protocols 
when (• protocol (eae-protocol (aref ca-table i})) 
return (eae-pa-of f set (aref ea-table i)) 
final ly (return 0)))) 
(cond ((nul I pkt)) 

((zerop offset) (return-gpkt (coerce gpkt pkt))) 
(T 
(setf (ares-pkt-protocol pkt) protocol) 
(setf (ares-pkt-length pkt) (etherword length)) 
(setf (ares-pkt-opcode pkt) ether-ares-oplREQUEST) 
(eetf •(make-pointer ethernet-address-ptr (ares-pkt-sea pkt)) 
•(coerce ethernet-address-ptr 

(make-pointer byte-ptr (aref (ethernet-address drv) 0)))) 
(loop for (i word) upfrom below length 
for (offset word) upfrom offset 
do (setf iarei (ares-pkt-«pa pkt) i) 

(aref (gdrv-other-ncp-f ields drv) offset))) 
(loop for (i word) upfrom below length 
for (j word) upfrom length 
do (setf (aref (ares-pkt-«pa pkt) j) 

(aref (earb-bytes earb) t))) 
(let ( ( (eaat ethernet-address-array-type) ) ) 

(loop for (i word) upfrom below 6 do (setf (aref eaat i) -1)) 

; (show-addr-tran-pkt pkt) 

(setf (gpkt-transrai t-size pkt) (- (type-size ares-pkt-type) 

(type-size gpkt-type-header) ) ) 
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(funcal I Uend-an-cthernet-packet drv) 

drv pkt (word ether-typefADDRESS-RESOLUTION) 
(make-pointer ethernet-address-ptp eaat))))))) 

F:>lmach>fep>chaos-ncp.1 n .10 Page 1 



;;;-»- tlode: Li I; Package:LiI; Base: 8.; Lowercase: T -»- 

;knoun bugs: 

; If tend-string can* t allocate a packet, it ur ites into rom 

; Same uith send-string-buf fered 

(include "Types-and-macros") 

(include "str ing.EXT** "network. EXT" "fsm.EXT") 

(deflitmacro unswapped-pkt-num (pkt) 

•(aref (gpkt-other-ncp-f ields-words ,pkt) 0)) 

(external add-once-per-echeduler-f unction ((function-to-add long))) 

? * 
;;;;;; The CHAOS UCP, eystem side of things. User stuff in CHAOS-USER 
5 ! 

• ? 
;;:;;; Kludges 
5 S 

(dcfatowmacro f ix-this-someday * (eetq junk 8)) 

iS NCP constants 



(defatommacro UORST -ROUTING-COST UolQQQ) 

(defatommacro host-doun-t imeout (« G9. 100.}) 
(defatcmmacrds 

C age-rout ing-tab I e- interval (« B0. 4)) 

( status-connect ions-intervai (// G0. 3)) 

( packet-repeat-delay-tnterval (// 60, 20,)) 

( sense-connect ions- Interval (* 60. 5)) 

( do-retransmissions- interval (// 60. 2)) 

(ti«teout-pending-rfcs-interval (« 50. 5)) 

{ send-routing-table- interval (* 60. 15.)) 
) 



Support macros 



(defmacro pkt-nuords (pkt) 

*(+ f trst-data-word-tn-pkt (Ish (1+ (pkt-nbytes ^pkt)) -1))) 

(defmacro pktnufn-< (a b) 

Mminusp (word (- ,a ,b))}) 
(defmacro pktnum-<- (a b) 

*(<- (uord (- ,a ,b) 0))) 
(defmacro pktnum-< (a b) 

Ms (uord (- ,a ,b)) 0)) 

(defmacro pktnum-> (a b) 
*(not (pktnum-s ,a »b))) 

(defmacro pktnum-l+ (a) 

•dogand Uollllll (1+ ,a))) 
(defmacro pktnum-incf (form) 

Msetf ,form (word (1+ ,form)))) 

(defmacro pktnum — (a b) 
Mlogand 177777 (- ,a ,b))) 
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Initialize all variables 



(defvar&ini tfun ini t-chaos-globai 9 
By-address word -1 ; my main chaos address 

uniquizer byte 8 ; connect ion uniquizer 

chaos-packet-input-liat pkt NULL-pKt 
chaos-packet-input-tai I pkt NULL-pkt 
pending-rfc-l (St pkt ^JULL-pkt 
pending-pfc-tai I pkt NULL-pkt 
nsepvers word 8 

cb-next-t ime-to-age-rout ing-table clock-value 8 
cb-nex t- 1 i me- to-send-rou t i ng- tab t e c I ock-va I ue 8 
cb-next-t tme-to-8tatu8-connect ione clock-value 8 
cb-next-t ime-to-sense-connect ions clock-value 8 
cb-next-t ime-to-timeout-pending-rfcs clock-value 8 
cb-next-time-to-do-retransra 188 ions clock-value 8 
) 

(defvariini tarrayfun ini t-chaoe-tables 
connect ion- table (array conn chaos-nax-conns) NULL-conn 
routing-table (array word nax-aubnet) 8 
cost-table (array word nax-subnet) WORST -ROUTING-COST 
) 

(defun ini t-chaos-dr i vers 

(loop for (i word) upfrom 8 below n-genera I -drivers 
as (drv genera I -driver) » (aref driver-table i) 
i f (and (not (nul I drv)) 

(i» (scnd-a-chaos-packet drv) tf'cant-send-a-chaos-packet) ) 
do 

(if (■ my-address -1) 
(setq my-address 

tf+BDLC (chaos-address drv) 
#-BDLC (rotr (word (chaos-address drv)) 8.) 
)) 
(setf (chaos-subnet drv) (progn #-BDLC (Idb-typed word <'o8818 (chaos-address drv)) 

<?+BDLC (Idb-typed word ^ol818 (chaos-address drv)))) 
(setf (chaos-dr iver-number+1 drv) (1+ U) 
(setf (aref routing-table (chaos-subnet drv)) (1+ i)) 
)) 

(defun ini t-chaos-ncp 
(ini t-chaos-g I oba Is) 
(ini t-chaos-tables) 

( ini t-chaos-dr i vers) ^ 

(add-once-per-scheduler-function #* step-chaos-background) 

;:;5 types: BF-INTERNAL, BF-BYTE5, BF-BYTES-BACICUARDS, BF-WORDS-LR, BF-UORDS-RL 

(defun make-chaos-packet-safe ((pkt pkt) (header byte-format) (data byte-format) ) 
(make-chaos-packet-header-safe pkt bf-internal) 
(make-chaos-packet-data-safe pkt data) 
(make-chaos-packet-header-safe pkt header)) 

(defun make-chaos-packet-safe-for-me ((pkt pkt)) 
(make-chaos-packet-header-safe pKt bf-internat) 
(make-chaos-packet-data-safe pkt bf-interna/)l 

;;; header tends towards bf-words-««, and should be BDLC independent 
(defun •ake-chaos-packet-header-safe ((pkt pkt) (new-bf byte-fornat)) 
(let* ((sav-bf new-bf) 

(old-bf (header-byte-format pkt))) 
(select old-bf 

(bf-internal (setq old-bf bf-words-r I ) ) 

(bf-bytes (setq old-bf )S(+60LC bf-words-rl «f-BDLC bf-words-lr) ) ) 
(select new-bf 

(bf-internal (setq new-bf bf-words-rl)) 

(bf-bytes (setq new-bf ;tr+BDLC bf-words-rl #-BDLC bf-words-lr))) 



• t • 
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(if im new-bf old-bf) 

(suap-chaos-pkt-portion pKt 0. 16.)) 
(setf (header-byte-format pkt) 8av-bf)n 

data is sad. H 1 figure it out, I'fl descpibe it 
;;; bf-words are probably done wrong here, but uell enough for byte streams 
(defun make-chaos-packet-data-safe ((pkt pkt) (new-bf byte-format)) 
(let* (isav-bf new-bf) 

(old-bf (data-byte-format pkt)) 
(int-bf (chaos-data-format pkt))) 
:; collapse to bytes or bytes-backwards 
(if (. old-bf bf-internal) (setq old-bf int-bf)) 
(if (- neu-bf bf-internal) (setq new-bf int-bf)) 
(setq old-bf 

(select old-bf 

(bf-«ords-rl #+BDLC bf-bytcs U-BDIC bf-bytes-backwards) 
(bf-words- I r #+BOLC bf-bytes-backwards #-BDLC bf-bytes) 
(otherwise old-bf))) 
(setq new-bf 

(select new-bf 

(bf-wcrds-rl #+BDLC bf-bytes #-BXC bf-bytes-backwards) 
(bf-words- 1 r «r+BDLC bf-bytes-backwards tf-BUlC bf-bytes) 
(otherwise new-bf))) 
{if (- new-bf old-bf) 

(swap-chaos-pkt-portion pkt 16. (+ 26, (logand (pkt-nbytes pkt) #o7777)))) 
(setf (data-byte-format pkt) sav-bf))) 

(defun (chaos-data-format byte-format) ((pkt pkt)) 

(if (or (member (pkt-opcode pkt) Mopn-op sts-op rut-op sns-op) ) 
ii (onlyS (pkt-opcode pkt)) dwd-op) ) 
bf-wor-ds-r I 
bf-bytes)) 

(cefun swap-chaos-pkt-portion ((pkt pkt) (beg word) (end word)) 
(loop for (i word) upfrom beg by 2 below end 
do (swapf (aref (pkt-bytes pkt) i) 

(aref (pkt-bytes pkt) (1+ i))))) 



Interface from the hardware driver 



(defun recei ve-chacs-packet-from-hardware ((drv genera I -driver) 

(pkt pkt)) 
(make-chaos-packet-header-tafe pkt bf-internal) 
5 (format debug-io*'*-tPacket in: ") (descr ibe-chaos-pkt pkt) 
(if (and iz (gpkt-al located-sire pkt) f trst-data-byte-in-pkt) 
(rerop (pkt-mbz pkt)) 
(i (gpkt-al tocated-size pkt) (+ f irst-data-byte-in-pkt 

(Idb-typed word i^ToeeiA (pkt-nbytes pkt))))) 
(progn (network-meter drv packets-in) 

(setf (aref routing-table (chaos-subnet drv)) 

(chaos-dr tver-number+1 drv)) 
(setf (aref cost-table (chaos-subnet drv)) 13.) 
(if (or (zerop (pkt-dest-address pkt)) 
(• (pkt-dest-address pkt) 

(rotr (chaos-address drv) U-^BDLC 8 <^-BDLC 8))) 
(if (not (null (setq pkt (assure-pkt-sizc pkt) ) ) ) 
(wi thout-interrupts 

(setf (pkt-nbytes pkt) (Idb-typed word #00014 (pkt-nbytes pkt))) 
(if (null chaos-packet- input-tai !) 

(setq chaos-packet-input- I i St pkt) 
(setf (pkt-link chaos-packet- input-tai I ) pkt)) 
(setq chaos-packet-input-tai I pkt))) 
(transmi t-pkt pkt))) 
(network-meter drv packets-other-reject) 
(return-pkt pkt))) 



Addi tion of servers 



4,887,235 
855 ^ 856 

<defvar server-alist (array server-aM st-sntry 10.) ()) 

(defun add-chaos-servcp ((contact string) (routine tong)} 

(set'f (server-contact-name (aref server-alist nservers)) contact) 
(setf (server-run-routine (aref server-alist nservers)) routine) 
( i ncf nservers) ) 



Sinple packet hacking 



(defun (al locate-pkt pkt) 

(let ((pkt (coerce pkt (allocate-gpkt nax-bytes-per-pkt) ))) 
(unless (nul I pkt) 
(set-fields pkt 

gpkt-user-byte-po inter 8 

gpkt-user-byte-count max-data-bytes-per-pkt 
pkt-«b2 8 ;«ake damn sure it's zero 

pkt-nbytes 8 ;nothing there yet 

)) 
pkt)) 

(defun (•ake-error-pkt pkt) ( (error-nessage string)) 
(coerce pkt (■ake-error-gpkt crror-«essage) )) 

(defun Cassure-pkt-size pkt) (Cpkt pkt)) ;fix this someday, this has several bugs 
(let ((neu-pkt (ailocate-pkt))) 
(unless (null new-pkt) 

(gpkt-copy-header (coerce, gpkt pkt) (coerce gpkt new-pkt)) 
(setf (pkt-header- longs new-pkt) (pkt-header- longs pkt)) 
(loop for (i word) upfroai 8 befou (Idb- typed word ^o8814 (pkt-nbytes pkt)) 
do (setf (aref (pkt-data-bgtes new-pkt) i) 

(aref (pkt-data-bytes pkt) i)))) 
(return-pkt pkt) 
new-pkt)) 

(defun return-pkt ((pkt pkt)) 
(rcturn-gpkt (coerce gpkt pkt))) 

(defun return-pkt-if-not-on-a-user-I ist ((pkt pkt)) 

(return-gpkt-i f-not-on-a-user-l ist (coerce gpkt pkt))) 
(defun return-pkt- i f-not-on-an-xni t- I ist ((pkt pkt)) 

(return-gpkt-i f-not-on-an-x«t t- I ist (coerce gpkt pkt))) 

(defun return-pkt- list ((pkt pkt)) 

(return-gpkt-1 ist (coerce gpkt pkt))) 
(defun return-pkt- I ist- if-not-on-an-xm t t- I ist ((pkt pkt)) 

(return-gpkt-list-if-not-on-an-xiii t-l ist (coerce gpkt pkt))) 

(defun (pkt-string string) ((pkt pkt)) 

(let ((string (make-string (pkt-nbytes pkt)))) 

(loop for (i word) upfrom below (pkt-nbytes pkt) 
do (setf (aref (string-bytes string) i) 

(aref (pkt-data-bytes pkt) i))) 
string) ) 

(defun set-pkt-str ing ((pkt pkt) (string string)) 

(Xset-pkt-str ing pkt 8 string B (string-length string))) 

(defun Xset-pkt-str ing ((pkt pkt) (pktfrm word) 

(string string) (from word) (to word)) 
(loop with (pkt I en word) • (min max-data-bytes-per-pkt (- to from)) 
for (i word) upfrom pktfrm below pkt ten 
for (j word) upfrom from 
do (setf (aref (pkt-data-bytes pkt) 1) 

(aref (string-bytes string) j)) 
finally (setf (pkt-nbytes pkt) i))) 



Simple connection hacking 
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(defun (nay-transmit booie) ((conn conn)) 
(and (« (state conn) open-state) 

(plusp (uindou-avdi i able conn)) } ) 

(defun (data-available boole) ((conn conn)) 
(not (null (read-pkts conn)))) 

(defun (finished-p boole) ((conn conn)) 

(op ii (uindou-avai lable conn) (forclgn-uindow-size conn)) 
(« (stats conn) open-state))) 

(defun (finish boole) ((conn conn)) 

(ppocess-wai t "net finish" tf'ftnished-p conn) 

(- (state conn) open-state) 

) 



Simple packet/connection interactions 



(defun send-stping ((conn conn) (string string)) 
(loop uith (stpfen wopd) ■ (stping-length stping) 

for (i uord) upfrom by max-data-bgtes-per-pkt belou strlen 
for (pkt pkt) - (al locate-pkt) 

do (progn (Xset-pkt-str ing pkt 8 string i strien) 
(send-pkt conn pkt dat-op)))) 

(defun send-string-buffered ((conn conn) (string string)) 
(loop with (strlen uord) - (string-length string) 

for (i word) upfrom by max-data-bytes-per-pkt betou strlen 
for (pkt pkt) - (stream-output-pkt conn) 
then (progn (send-pkt conn pkt dat-op) (allocate-pkt) ) 
do (sctf (stream-output-pkt conn) NULL-pkt) 
do (Xset-pkt-str ing pkt (pkt-nbytes pkt) string i strlen) 
finally (if (• (pkt-nbytes pkt) max-data-bytes-per-pkt) 
(send-pkt conn pkt dat-op) 
(setf (stream-output-pkt conn) pkt) ) ) ) 



Hairier connection routines 



(defun (make-error-connection conn) ((error-message string)) 

(let ((conn (coerce conn (fam-ai locate (type-size conn-type))))) 
(if (not (nul I conn)) 
(set-fields conn 

conn-error-message error-message 
conn-error -conn true 

)) 
conn) ) 

(defun (make-connection conn) 

(loop for (idx uord) upfrom belou chaos-max-conns 
when (null (aref connect ion- table idx)) 
return 
(let ((conn (temporary (coerce conn (fsm-al locate 

(type-size conn-type))) 
(alloc conn ^* fsm-al locate) )) ) 
(if (not (nul I conn)) 
(progn 

(set-fields conn 

conn-error-message NULL-string 
conn-erpop-conn false 
I oca \ -M i ndou-s i ze 8 
fopeign-uindou-stze 8 
state inact i ve-state 

fopeign-popt 8 
I oca I -addpess my-addpess 
local -idx (byte idx) 

local-uniq (if (zepop (incf uniquizep)) 

(incf uniquizep) 
uniquizep) 
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rcad-pkts "'" NULL-pkt 
read-pkts-tast NULL-pkt 
received-pkts NULL-pkt 

pkt-nuiB-read -1 
pkt-nu«-received -1 
pkt-nura-acked -1 
t tme-last-peceived TIME 
auto-status-threshold 8 

stream- tnput-pkt NULL-pkt 
pkt-pecei ve-event-mask 8 

pkt-rcceive-event-channel (make-pointer event-channel 

junk-cm) 

send-pkts NULL-pkt 

send-pkts-last NULL-pkt 

pkt-num-sent 8 

send-pkt-acked 8 

Hindou-avai labfe 

stpeam-output-pkt NULL-pkt 

pkt-xmi t-event-mask 8 

pkt-xmi t-event-channel (make-pointep event-channel 

junk-em) 
) 
(setf (apef connect ion- table idx) conn))) 
conn) 
finally 
(pctupn fJULL-conn) )) 

(defun pemove-conn ((conn conn)) 
( i f (not (nul I conn) ) 
(ppogn 

(if (conn-error-conn conn) 

(if (not (null (conn-eppor-message conn))) 

(retupn-string (conn-eprop-message conn) ) ) 
(free-aM-read-pkts conni 
(free-ai l-recei ved-pkts conn) 
(fpee-al i-send-pi^ts conn) 

(setf (aref connect ion-tao I e (I oca I -idx conn)) NULL-conn) ) 
(tempopapy (f sm-fpee (coepce long conn) ) 

(fpee conn conn ^' f sm-free) ) ) ) ) 

(defun fpee-al l-pead-pkts ((conn conn)) 
(let ((head (pead-pkts conn))) 

(setf (pead-pkts conn) NULL-pkt) 
(setf (pcad-pkts-last conn) NULL-pkt) 
(petupn-pkt-i ist head))) 

(defun fpee-al l-pecei ved-pkts ((conn conn)) 
(let ((head (pecei ved-pkts conn))) 
(setf (pecei ved-pkts conn) NULL-pkt) 
(petupn-pkt-l ist head))) 

(defun fpee-al { -send-pkts ((conn conn)) 
(let ((head (send-pkts conn))) 

(setf (send-pkts conn) NULL-pkt) 
(setf (send-pkts-last conn) NULL-pkt) 
(petupn-pkt-l ist- 1 f-not-on-an-xmi t-l ist head) )) 



Haiptep packet/connection intepactions 



(defun (»end-pkt-ok? booie) ((conn conn)) 

(op (not (member (state conn) "(open-state pfc-sent-state) ) ) 
(may-tpansmi t conn))) 
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(defun (scnd-pkt bootc) ((conn conn) (pkt pkt) (opcode byte)) 
(if (and (or (> opcode dat-op) 
(- opcode eof-op)) 
(ppogn (or (send-pkt-ok? conn) ;may get called from sched 
(ppocess-uai t "Net out* #*send-pkt-ok? conn)) 
(- (state conn) open-state))) 
(progn (setf (pkt-opcode pkt) opcode) 
(decf (uindou-avai table conn)) 
(transmi t-nor«al-pkt conn pkt true) 
true) 
(ppogn (return-pkt pkt) 
false))) 

(defun send-unc-pkt ((conn conn) (pkt pkt) 

(num word) (ack-nun uord) ) 
( se t f (pk t -nu« pk t ) num ) 
(setf (pkt-ack-num pkt) ack-num) 
(tpansBii t-nor«al-pkt conn pkt false)) 

(defun send-listen-pkt ((conn conn) (pkt pkt)) 
(if im (state conn) inactive-state) 
(return-pkt pkt) 
(setf (state conn) listening-state) 

(loop for (pp pkt-ptp) ■ (wake-po inter pkt-ptp pending-rfc-l tst) 
then (make-pointer pkt-ptr (pkt-link rfc-pkt)) 
as (rfc-pkt pkt) • •pp 
unti 1 (nut I pfc-pkt) 
when (contact-names-equal pfc-pkt pkt) 
do 

(return-pkt pkt) 
(setf ©pp ipkt-link rfc-pkt)) 
(rfc-tneets-lsn conn rfc-pkt) 
(return) 
final ly (setf (send-pkts conn) pkt)))) 

(defun fast-answer-str jng ((contact string) (answer string)) 

(fast-response-string contact answer ans-op 8)) 
(defun fast-reject-string ((contact string) (reason string)) 

(fast-response-string contact reason c(s-op 9)) 
(defun fast-forward-string ((contact string) (message string) (new-host word)) 

(fast-pesponse-str ing contact message fud-op new-host)) 

(defun fast-response-string ((contact string) (response string) 

(opcode byte) (ack-field word)) 
(loop for (pp pkt-ptr) • (make-pointer pkt-ptr pending-rfc-l tst) 
then (make-pointer pkt-ptr (pkt-link pkt>) 
as (pkt pkt) * spp 
unti I (nuf / pkt) 

when (contact-matches-rfc contact pkt) 
do 

(setf tpp (pkt-link pkt)) 

(set-pkt-str ing pkt response) 

(setf (pkt-opcode pkt) opcode) 

(swapf (pkt-dest-port pkt) (pkt-src-port pkt)) 

(setf (pkt-ack-num pkt) ack-field) 

(transmi t-pkt pkt) 

(return) 

)) 



(defun (get-next-pkt pkt) ((conn conn) Ino-hang-p boole)) 
(or no-hang-p 

(get-next-pkt-ok? conn) 

(process-wait "Net in" JC* get-next-pkt-ok? conn)} 
(let ((pkt (read-pkts conn))) 
(if (null pkt) 

(if (not (member (state conn) * (open-state foreign-state))) 
(setq pkt (make-error-pkt 

"Connection in bad state to return a packet."))) 
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(if (null (setf (read-pKts conn) (pkt-l Ink pkt) ) ) 

(setf (read-pkts-last conn) NULL-pkt)) 
(if (not (Biember (state conn) ' (open-state pfc-receivcd-state foreign-state))) 

(setf (state conn) inactive-state)) 
(if {0 unc-op (pkt-opcode pkt)) 

(progn (setf (pkt-num-read conn) (pkt-nu» pkt)) 
(if (and (- (state conn) open-state) 

(£ (decf (auto-status-thpeshold conn)) 3)) 
(transmi t-sts conn)))) 
(set-fields pkt 

gpkt-user-byte-pointep 
gpkt-user-byte-count (pkt-nbytes pkt)) 

pkt)) 

(defun (get-next-pkt-ok? boole) ((conn conn)) 
(op (not (nuM (pead-pkts conn))) 

(not (wembep (state conn) ' (open-state fopeign-state) ))) ) 



Tpansniit side of things 



(defun tpansmt t-nopwai-pkt ((conn conn) (pkt pkt) (needs-acking boole)) 
(setf (pkt-link pkt) NULL-pkt) 
( i f needs-acking 

(ppogn (setf (unswapped-pkt-num pkt) 
(setf (pkt-num pkt) 

(setf (pkt-num-sent conn) 

(pktnum-l+ (pkt-nuni-sent conn))))) 
(setf (pkt-nuffl-acked conn) 

(setf (pkt-ack-num pkt) 

(pkt-nuffl-pead conn))) 
(setf (auto-status-thpeshotd conn) ( (oca I -window-si ze conn) ) 
(if (null (send-pkts-last conn)) 
(setf (send-pkts conn) pkt) 
(setf (pkt-link. (send-pkts-last conn)) pkt)) 
(setf (send-pkts-last conn) pkt) 
(setf (gpkt-on-a-uscp-l ist? pkt) tpue)) 
(setf (gpkt-on-a-usep-l ist? pkt) false)) 
(tpansni t-pkt-fop-conn conn pkt)) 

(defun tpansmi t-sts ((conn conn)) 

(tpanswi t-sts-pkt conn (al locate-pkt) ) ) 
(defun tpansmi t-sts-pkt ((conn conn) (pkt pkt)) 
(unless (nul I pkt) 

(setf (pkt-opcode pkt) sts-op) 

(setf (pkt-nbytes pkt) 4) 

(setf (pkt-num pkt) (pkt-num-sent conn)) 

(setf (pkt-nuni-acked conn) 

(setf (pkt-ack-num pkt) 

(pkt-num-pead conn))) 
(setf (pkt-sscond-data-wopd pkt) ( local -window-size conn)) 
(setf (pkt-f ipst-data-wopd pkt) (pkt-num-pecei ved conn)) 
(tpansni t-norifiai-pkt conn pkt false))) 

(defun transmi t-sns ((conn conn)) 

(transmi t-sns-pkt conn (al locate-pkt) ) ) 
(defun tpansmi t-sns-pkt ((conn conn) (pkt pkt)) 
(unless (nul 1 pkt) 

(setf (pkt-opcode pkt) sns-op) 
(setf (pkt-nbytes pkt) 4) 
(setf (pkt-num-acked conn) 

(setf (pkt-ack-num pkt) 

(pkt-num-read conn))) 
(transmi t-normal-pkt conn pkt false))) 

(defun tpansmi t-pkt-fop-conn ((conn conn) (pkt pkt)) 
(setf (pkt-dest-popt pkt) (fopeign-port conn)) 
(setf (pkt-spc-port pkt) (local-popt conn)) 
; (format debug- i o^-^XTPFC: ") (descp ibe-chaos-pkt pkt) 
(transmi t-pkt pkt)) 
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(eiefun transmit-pkt iipki pkt)) 
<make-chaos-packet-header-safe pKt bf-internal) 
: (format debug-io"-tPacket out: **) (describe-chaos-pkt pkt) 
(let* ((subnet (uord (pkt-dest-subnet pkt))) 
(Ideat (pkt-dest-addres8 pkt)) 
( (route word) 8) 
((driver-index+1 word) (cond iiz subnet max-subnet) (word 0)) 

((S (setq route (aref routing-table subnet)) 

n-general-dr i vers) 
route) 
((2 (setq Idest route 

subnet (Ishr idest 8)) 
•aM-subnet) 
8) 
((s (setq route (aref rout ing-table subnet)) 

n-genera I -drivers) 

route) 
(T 8))) 
(drv (if (zerop driver-indcx+1) 
NULL-genera 1 -dr i ver 
(aref driver- table (1- driver-index+lJ ))) ) 
(if (null drv) 

(return-pkt-if-not-on-a-user-l jst pkt) 
(setf (gpkt-transmit-size pkt) (+ 16. (Idb-typcd word #08814 (pkt-nbytes pkt)))) 
(funcall (send-a-chaos-packet drv) drv pkt Idest)))) 

{defun transmit- los-pkt ((pkt pkt) (string string)) 
(setf (pkt-opcode pkt) tos-op) 
(set-pkt-string pkt (if (null string) 

"Reason not supplied." 
string) ) 
(swapf (pkt-dest-port pkt) (pkt-src-port pkt)) 
Ctranswit-pkt pkt)) 



• « • 1 • 1 



Receive side of things. 



(defun cb-process-recetved-packets 

(loop for (pkt pkt) • chaos-packet- input- I i St 
unti I (nul t pkt) 
do (wi thout-interrupts 

(if (null (setq chaos-packet-input-t ist (pkt-l ink pkt) ) ) 
(setf chaos-packet-input-tai I NULL-pkt))) 
(nake-chaos-packet-safe-for-ffle pkt) 
; (descr tbe-chacs-pkt pkt) 
(setf (pkt-l ink pkt) NULL-pkt) 
(let ((opcode (pkt-opcode pkt))) 

(cond ((»inusp opcode) (recei ve-eof-or-dat pkt)} 
( (or (zerop opcode) 

iz opcode wiax-op) ) 
(transwi t-los-pkt 
pkt "I don't understand gour opcode.")) 
(T jy. (loop for (opcode handler) 

in '((rfc-op receive-rfc) 
(opn-op recei ve-opn) 
(cIs-op receivc-cls) 
(fwd-op recei ve-fwd) 
(ans-op recei ve-ans) 
(sns-op receive-sns) 
(sts-op recei ve-sts) 
(rut-op receive-rut) 
(i OS-op receive- I os) 
(Isn-op return-pkt) 
(■int-op return-pkt) 
(eof-op receive-eof-or-dat) 
(unc-op recei ve-unc) 
(brd-op recei ve-brd) 
(otherwise return-pkt) ) 
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collect •(, opcode (, handler pkt)) 
into setect-l terns 
final ly (return 

'(select opcode ,*select-i terns) )) 
))})) 



Packet reception 



(defun (f ind-conn-for-pkt conn) ((pkt pkt)) 
(let* ((idx (pkt-dest-idx pkt)) 
(conn (rf (and (> idx 0) 

(< idx chaos-max-conns) ) 
(aref connection-table idx) 
NULL-conn))) 
(if (and (not (null conn)) 

(- (pkt-dest-address pkt) ( local -address conn)) 
(■ (pkt-src-address pkt) (foreign-address conn)) 
(if (rerop < foreign- idx conn)) 

(and (• (state conn) rfc-sent-state) 
(■leraber (pkt-opcode pkt) 

' (opn-op ans-op cIs-op fud-op sns-op))) 
(• (pkt-src-index-nuM pkt) (foreign-index-num conn))) 
(or (m (pkt-dest-index-nutn pkt) ( local -index-num conn)) 
(and (- (pkt-opcode pkt) rfc-op) 

(■ember (state conn) ' (open-state rfc-received-state)))) 
) 
(progn (setf (t i me- last-received conn) TIPIE) 
conn) 
NULL-conn) ) ) 

(defun give-pkt-to-conn ((conn conn) (pkt pkt)) 
; (format debug-io"^XGi ving packet (^) to connection." (coerce long pkt)) 
; (descr ibe-chaos-pkt pkt) 
(setf (pkt-link pkt) NULL-pkt) 
(if (null (read-pkts-last conn)) 

(progn Jsetf (read-pkts conn) pkt) 

(setf •(pkt-receive-event-channel conn) 

(logior •(pkt-receive-event-channel conn) 
(pkt-rece i ve-event-mask conn) ) ) ) 
(setf (pkt-link (read-pkts-last conn)) pkt)) 
(setf (read-pkts-last conn) pkt)) 
(defun recetve-rfc ((pkt pkt)) 

(cond ((loop for (rfc-pkt pkt) - pending-rfc-I ist 
then (pkt-i ink rfc-pkt) 
uhcn (nul I rfc-pkt) 
return false 

uhen (and (- (pkt-src-index-num pkt) (pkt-src-index-num rfc-pkt)) 
(- (pkt-src-address pkt) (pkt-src-address rfc-pkt)) 
(• (pkt-dest-address pkt) (pkt-dest-address rfc-pkt))) 
return true) 
(return-pkt pkt) I ;duplicate unhandled rfc 

((loop with (conn conn) 

for (i uord) upfrom 8 below chaos-max-conns 

if (not (null (setq conn (aref connect ion- table i)))) 

do (cond ((and (• (state conn) listening-state) 

(contact-names-equal pkt (send-pkts conn) ) ) 
(free-al I-send-pkts conn) ; flush the LSN 
(rfc-«eet8-lsn conn pkt) 
(return true)) 
((and (member (state conn) * (rfc-received-state open-state) ) 
(- (pkt-src-index-num pkt) (foreign-index-num conn)) 
{- (pkt-src-address pkt) (foreign-address conn)) 
(- (pkt-dest-address pkt) ( I oca I -address conn))) 
(setf (time-last-received conn) TIHE) 
(return-pkt pkt) -.duplicate rfc for conn 
(return true))) 
final ly (return false))) 
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;;; aay uc "should check known server functions?? 
(T 
(if (nut I pendf ng-rfc-l ist) 

(setq pending-rfc-I ist pkt) 
(setf (pkt-tink pending-rfc-tai I ) pkt)) 
(setq pending-rfc-tai I pkt) 
(f ire-up-a-server pkt)))) 

(defun receive-opn ((pkt pkt)) 
: (format debug- to" -vXReceiving OPN packet..,") 
(let ( (conn (f ind-conn-for-pkt pkt) ) ) 
(if (null conn) 

(transmi t-Ios-pkt pkt "I don't have a connection for your OPN.") 
; (format debug- io" found a connection for it...") 
(if (• (state conn) rfc-sent-state) 

(progn (sctf (state conn) open-state) 

; (format debug- io" it uas in RFC sent.. •") 

(setf (foreign-tndex-nuffl conn) (pkt-src-index-nu» pkt)) 

(setf (pkt-num-recei ved conn) 

(setf (pkt-num-read conn) 
(pkt-num pkt))) 
(process-sts-l ike-pkt conn pkt))) 
; (format debug- to*Transmi tting SIS...") 
(transmi t-sts-pkt conn pkt)))) 

(defun receive-cis ((pkt pkt)) 

(let ((conn (f ind-conn-for-pkt pkt))) 
(i f (nul I conn) 

(return-pkt pkt) 
(setf (state conn) cl s-recei ved-state) 
(givc-pkt-to-conn conn pkt)))) 

(defun receivc-fwd ((pkt pkt)) 

(let ((conn (f ind-conn-for-pkt pkt))) 
( i f (or (nul t conn) 

(»• (state conn) rfc-sent-state) 
(null (send-pkts conn))) 
(return-pkt pkt) 
:;bash conn and RFC in place, let retransmit take care of the rest 
(sctf Tforeign-address conn) 

(setf (pkt-dest-address (send-pkts conn)) 
(pkt-ack-num pkt)))))) 
(defun recetve-ans ((pkt pkt)) 

(let ((conn (f ind-conn-for-pkt pkt))) 
(if (cr (nul \ conn) 

im (state conn) rfc-sent-state)) 
(return-pkt pkt) 
(setf (state conn) answered-state) 
(gi ve-pkt-to-conn conn pkt)))) 

(defun receive-sns ((pkt pkt)) 

(let ((conn (f ind-conn-for-pkt pkt))) 
(if (nui I conn) 

(transmi t- I os-pkt pkt "You just SNSed a non-existent connection.") 
(receipt conn (pkt-ack-num pkt)) 
(if (pktnum-> (pkt-num pkt) (send-pkt-acked conn)) 

(setf (send-pkt-acked conn) (pkt-num pkt))) 
(transmi t-sts-pkt conn pkt)))) 

(defun receive-sts ((pkt pkt)) 

(let ( (conn (f ind-conn-for-pkt pkt) ) ) 
(i f (nul I conn) 

(transmi t- I os-pkt pkt "You just STSed a non-existent connection.") 
(process-sts-Mke-pkt conn pkt) 
(return-pkt pkt) 
(rotransmi t-for-conn conn)))) 

(defun receive-rut ((pkt pkt)) 

(loop with (gatewag word) « (pkt-src-address pkt) 

for (i word) upfrom B by 2 below (// (pkt-nbytes pkt) 2) 
for (subnet word) • (arcf (pkt-data-words pkt) i) 
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for (cost word) » (aref (pkt-clata-words pkt) (1+ i}) 
do (if (and (not (zerop subnet)) 
(< subnet aax-subnet) 
(> cost 17.) 

(< cost (aref cost-table subnet))) 
(ppogn (setf (aref cost-table subnet) cost) 

(eetf (aref routing-table subnet) gateway)))) 
(return-pkt pkt)) 

(defun receive-!os ((pkt pkt)) 

(let ((conn (f ind-conn-for-pkt pkt))) 

(if (or (null conn) im (state conn) open-state)) 
(return-pkt pkt) 
(setf (state conn) los-recei ved-state) 
(gi ve-pkt-to-conn conn pkt)))) 

(defun receive-unc ((pkt pkt)) 

f ix-thi s-someday 

(return-pkt pkt)) 
(defun pcceive-brd ((pkt pkt)) 

f ix-thi s-someday 

(return-pkt pkt)) 

(defun receive-eof-or-dat ((pkt pkt)) 
(setf (pkt-tink pkt) NULL-pkt) 
(let {(conn (f ind-conn-for-pkt pkt))) 
(cond ( (nul I conn) 

(transmi t-Jos-pkt pkt "No connection for data packet.")) 
((x (state conn) open-state) 

(transmi t-los-pkt pkt "lly connection is not open.")) 
((pktnum-> (pkt-num pkt) (+ (pkt-num-read conn) 

(local-uindow-stze conn))) 
: (describc-chaos-pkt pkt) (format debug- io"*SPacket out of uindou.") 
(return-pkt pkt)) ;out of uindou 

((progn (receipt conn (pkt-ack-num pkt)) 

(if (pktnum-> (pkt-num pkt) (send-pkt-acked conn)) 

(setf (send-pkt-acked conn) (pkt-num pkt))) 
(pktnum-s (pkt-num pkt) (pkt-num-recei ved conn))) 
; (describe-chaos-pkt pkt) (format debug- io'''%'IAt ready have it.") 
(transmi t-sts-pkt conn pkt)) ;already received it 
{{- (pkt-num pkt) (pktnum-l+ (pkt-num-recei ved conn))) 
(loop do (gi ve-pkt-to-conn conn pkt) 
; (format debug- i o"'^tG i ven to conn.") 

(pktnum-incf (pkt-num-recei ved conn)) 
(setq pkt (received-pkts conn)) 
unti I (or (nul 1 pkt) 

(i« (pkt-num pkt) 

(pktnum-l+ (pkt-num-received conn)))) 
;do (format debug-io"'MXPul led another off of received-pkts") 
do (setf (received-pkts conn) (pkt-link pkt)))) 
(T 

; (describe-chaos-pkt pkt) (format debug- io'-^XREOD, splicing,,.") 
(loop for (pp pkt-ptr) - (make-pointer pkt-ptr (received-pkts conn)) 
then (make-pointer pkt-ptr (pkt-l ink •pp) ) 
i f (nut i ftpp) 
do (setf ©pp pkt) 

; (format debug-io"on the end.") 
(return) 
if (- (pkt-num pkt) (pkt-num tpp)) 

do (return-pkt pkt) ;dupltcate on out of order list 
; (format debug- to"dupl icate, ") 
(return) 
if (pktnum-< (pkt-num pkt) (pkt-num ftpp)) 
do (setf (pkt-link pkt) mpp) 
(setf mpp pkt) 

J (format debug- io" in the middle.") 
(return) 
)) 
))) 
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Other connect ton/pacKet interaction functions 



(defun proce5s-«ts-i ike-pKt {(conn conn) (pkt pkt)) 
(receipt conn (pkt-f irst-data-word pkt)) 

(setf (foreign-uindou-tize conn) (pkt-«econd-data-word pkt)) 
(if {pktnum-> (pkt-num pkt) (send-pkt-acked conn)) 

(setf (send-pkt-acked conn) (pkt-num pkt))) 
(update-uindou-avai table conn)) 

(defun receipt ((conn conn) (ack-Iev word)) 
(loop for (pkt pkt) » (tend-pkts conn) 

until (or (null pkt) (pktnum-< ack-lev (unswapped-pkt-nua pkt))) 
do (setf (send-pkts conn) (pkt- link pkt)) 
(decf (send-pkts- length conn)) 

; (format debug-io'-^trpinoaxl *C" (coerce long pkt)) 
(ui thout-interrupts (return-pkt-i f-not-on-an-x«i t- I t st pkt) ) 
finally (if (null (send-pkts conn)) 

(setf (send-pkts- last conn) NULL-pkt)))) 

(defun update-uindou-avai table ((conn conn)) 
(let {(old-available (uindou-avai table conn) )) 
(if (and (plusp 

(setf (uindou-avai I able conn) 
(■ax old-avat table 

(- (foreign-uindou-size conn) 
(pktnuB — (pkt-num-sent conn) 

(send-pkt-acked conn)))))) 
(zerop otd-avai lable)) 
(setf •(pkt-x«i t -event-channel conn) 

(logior «(pkt-K»i t-evcnt-channel conn) 
(pkt-xni t-event-»ask conn)))))) 

(defun retransmi t-for-conn ((conn conn)) 

(loop for (pkt pkt) - (send-pkts conn) then (pkt-link pkt) 
unti I (nul t pkt) 
if (and (not (gpkt-on-an-xni t-l ist? pkt)) 

(i TIME U {gpkt-x«i t-ti«e pkt) packet-repeat-delay-interval))) 
do (make-chaos-packet-header-safe pkt bf- internal) 
(setf (pkt-num-acked conn) 

(setf (pkt-ack-nuM pkt) 

(pkt-num-read conn))) 
(trans»it-pkt pktJ)) 

(defun (contact-«atches-rfc boole) ((contact string) (rfc pktJ) 
(and (or (and (> (pkt-nbytes rfc) (string-length contact)) 

{- (aref (pkt-data-bytes rfc) (string- length contact)) #\space)) 
(- (pkt-nbytes rfc) (string-length contact))) 
(loop for (i word) upfrom belou (string-length contact) 
atuays (• (aref (pkt-data-bytes rfc) i) 

(aref (string-bytes contact) i))))) 

(defun (contact-names-equal boole) ((rfc-pkt pkt) (Isn-pkt pkt)) 
(let ((tsn-nbytes (pkt-nbytes Isn-pkt))) 
(and (> (pkt-nbytes rfc-pkt) Isn-nbytes) 

(or (• (pkt-nbytes rfc-pkt) Isn-nbytes) 

(• (aref (pkt-data-bytes rfc-pkt) Isn-nbytes) atfXspace)) 
(loop for (i uord) upfroa 9 belou Isn-nbytes 

aiuays (- (aref (pkt-data-bytes rfc-pkt) t) 

(aref (pkt-data-bytes Isn-pkt) i)))))) 

(defun rfc-ineets-.lsn ((conn conn) (pkt pkt)) jpkt is the rfc 
(setf (pkt-link pkt) NULL-pkt) 
(set-fields conn 

foreign-port (pkt-src-port pkt) 

local -address (pkt-dest-address pkt) 

foreign-uindou-size 1 

{pkt-nuw-read pkt-num-recei ved pkt-num-acked) (pkt-num pkt) 

(read-pkts read-pkts- last) pkt 
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State pfc-pccei ved-etate 

ti«e- last-received TIME 

) 
(setf •(pkt-recei ve-event-channel conn) 

(logior •(pkt-peceive-event-channel conn) 
(pkt-rece't ve-event-uask conn) ) ) ) 

{defun f ire-up-a-server ((pkt pkt)) 

(loop for (i uord) upfrom 8 below nservers 

as (contact string) - (server-contact-name (aref server-aMst i)) 

when (contact-eatches-rfc contact pkt) 

do 

(funcati (server-run-routine (aref server-alist i))) 

(return) 

)) 



Chaos background 'process* 



(defvar cb-uakeup-tiae ctock-value 8) 

(defaacro cb-wait (tiae- variable n-ticks) 
Msetq cb-wakeup-tiae (ain cb-uakeup-tiite 

(setq ,tiae-variable (+ TIME ,n-ticks)) )) ) 
(defaacro cb-do-i f-t lae-has-passed (tiae-var irest foras) 
Mif C< TinE .tiae-var) 

(setq cb-uakeup-tiae (ain cb-uakeup-tiae , tiae-var)) 
••foras)) 

(defun step-chaos-background 
(setq cb-wakeup-tiae FOREVER) 
(cb-process-rece i ved-packets) 
(cb-send-streaa-output-packets) 
(cb-aaybe-age-rout i ng- tab 1 e) 
(cb-aaybe-send-rout i ng- tab I •) 
(cb-aaybe-status-connec t i ons) 
(cb-aaybe-sense-connect i ons) 
(cb-aaybe- 1 i aeou t-pend i ng-r f cs) 
(cb-aaybe-do-retransa i ss i ons) 
) 

(defun cb-aaybe-age-routrng-table 
(cb-do- i f-t t ae-has-passed 
cb-next-tiae-to-age-routing-table 
(loop for (subnet uord) upfroa 8 below aax-subnet 

do (if (< (aref cost-table subnet) UORST-ROUTING-COST) 
(incf (aref cost-table subnet)))) 
(cb-ua r t cb-nex t- 1 i ae- to-age-rou t i ng- tab I e age-rout i ng- tab I e- i n terva I ) ) ) 

(defun cb-aaybe-send-rout I ng- table 
(cb-do- i f- t i ae-has-passed 
cb-next-tiae-to-send-r outing- table 
(if iz nuaber-of-a I ive-chaos- inter faces 2) 
(loop with (pkt pkt) 

for (drvidx word) upfroa 8 below n-genera I -drivers 
for (drv genera I -driver) • (aref driver-table drvidx) 
when (and (not (null drv)) 

(* (scnd-a-chaos-packet drv) 
tf'cant-send-a-chaos-packet)) 
do (if (null (setq pkt (a( locate-pkt) )) 
(return) 
(setf (pkt-opcode pkt) rut-op) 
(setf (pkt-src-address pkt) 

#+BDLC (chaos-address drv) 
^'-BDLC (rotr (chaos-address drv) 8) 
) 
(setf (pkt-dest-address pkt) 8) 
(loop with (pkttdx word) • 8 

with (ay-cost word) - (aref cost-table (chaos-subnet drv>) 
for (subnet uord) upfroa 1 below aax-subnet 
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for <co«t uord) • (aref cost-table subnet) 
when C< cost UORST-ROUTING-COST) 

do (progn (eetf (aref (pkt-data-words pkt) pktidx) subnet) 
(setf (aref (pkt-data-uords pkt) (l-i- pktidx)) 

{* cost My-cost)) 
(incf pktidx 2)) 
final lu (setf (pkt-nbytes pkt) (» pktidx 2))) 
(transmit-pkt pkt)))) 
(cb-wa i t cb-next-t i me-to-send-rout i ng-tab I e send-rout i ng-tab I e- 1 nterva I ) ) ) 

(dcfun cb-maybe-status-conncctions 
4^cb-do- ) f - 1 i ffle-has-passed 

Cb-ncxt-time-to-status-connect tons 
(loop for (i uord) upfrom betou chaos-max-conns 
for (conn conn) • (aref connection-table \) 
if (and (not (null conn)) 

{• (state conn) open-state) 
(connection-needs-status conn) 

(m (pkt-nuin-acked conn) (pkt-nue-received conn))) 
do (trans«it-sts conn)) 
(cb-uai t cb-next-ti«e-to-status-connectlons status-connections-interval))) 

(defun cb-»aybe-sense-connections 
(cb-do-if-tine-has-passed 
cb-next-t iee-to-sensc-connect tons 
(loop for (i uord) upfrom 8 betou chaos-«ax-conns 
for (conn conn) - (aref connection-table i) 
if (and (not (null conn)) 

(• (state conn) open-state)) 
if iz {- TIflE (tiee-last-received conn)) host-down-tieeout) 
do (setf (state conn) host-doun-state) 
else do (transei t-sns conn) 
) 
(cb-uai t cb-next-t t Be- to-sense-connect i ons sense-connect i one- i nterva 1 ) ) ) 

(defun cb-eaybe-t iaeout-pending-rfcs 
(cb-do- i f-t i ee-has-passcd 
cb-next-t i ■e-to- 1 i eeou t-pend i ng-r f cs 

(loop uith (pp pkt-ptr) • iaake-pointer pkt-ptr pending-rfc-l ist) 
as (pkt pkt) • cpp 
unti I (nul 1 pkt) 

if (> (- TirE (gpkt-receive-ti«e pkt)) tf. (« B8. 28.)) ;28 seconds 
do 

;(for«at debug- io"*tTi mi ng out a RFC:") (describe-chaos-pkt pkt) 
(setf mpp (pkt-t ink pkt)) 
(return-pkt pkt) 
else do (setq pp (eake-pointer pkt-ptr (pkt-link pkt))) 

(cb-uai t cb-next-t i»e-to-ti»eout-pendi ng-r fcs t ieeout-pcnding-rfcs-interval) ) ) 

(defun cb-eaybe-do-retranswissions 
(cb-do- i f-t i me-has-passed 
cb-next-t i me- to-do-re transw i ss i ons 
(loop for (i uord) upfrom 8 belou chaos-max-conns 
as (conn conn) • (aref connection-table i) 
if (and (not (null conn)) 

(member (state conn) ' (open-state rfc-sent-state))) 
if (> (- TlflE (time-last-received conn)) host-doun-timeout) 
do (setf (state conn) host-doun-state) 
else do (retransmi t- for -conn conn)) 
(cb-wa i t cb-next-t (me- to-do-retransm i ss i ons do-retransm i ssions- 1 nterva I ) ) ) 

(defun cb-send-stream-output-packets 
(loop with (pkt pkt) 

for (i uord) upfrom 8 belou chaos-max-conns 
as (conn conn) - (aref connect ion- table i) 
if (and (not (nul I conn)) 

(may-transmit conn) 

(not (null (progl (setq pkt (stream-output-pkt conn)) 

(setf (stream-output-pkt conn) NULL-pkt) ) )) ) 
do (send-pkt conn pkt dat-op) 
)) 



4,887,235 
879 __^ 880 

(defaacro onlyS (bgte) Mlogand (word .bgta) #o377}) 

(defun describe-chaos-pkt ((pkt pkt)) 

(format debug- io'''»'tChaos packet description: *) 
(ma<e-chacs-pacK.et-Bafe-for-«e pkt) 

(setf (pkt-nbgtes pkt) (logand (pkt-nbytes pkt) UolllD) 
(let {(op (onlyS (pkt-opcode pkt)))) 
(fornat debug- to'^^ZOpcode m mJ^ m ^A" 
op 
(select op 

(rfc-op "Request for connection") 
(opn-op "Open the connection") 
(cIs-op "Ciose connection") 
(fwd-op "Forward the request") 
(ans-op "Answer to simple request") 
(sns-op "Sensing the connection") 
(sts-op "Status of connection") 
(rut-op "Routing information") 
(los-op "Losing connection") 
(■nt-op "Maintenance") 
(eof-op "End of fiie marker") 
(unc-op "Uncontrolled packet") 
(brd-op "Broadcast request") 
(otherwise 
(cond ((< op dat-op) "Unknown opcode") 
((a op dwd-op) "Uord data") 
(T "Byte data"))))) 
(format debug- io"*XLength: ^. bytes" (pkt-nbytes pkt)) 
(format debug- io"**XTo: «-0,~0^!tFrom: *0,^" 
(pkt-dest-address pkt) 
(pkt-dest-index-num pkt) 
(pkt-src-address pkt) 
(pkt-src-index-num pkt)) 
(format debug- io"*XPacket number: ^-^XAck number: *%€" 
(pkt-num pkt) 
(pkt-ack-num pkt)) 
(show-chaos-packet-data pkt op) 
; (return-gpkt (coerce gpkt pkt)) 
)) 

(tiefun show-chaos-packet-data ((pkt pkt) (op word)) 
(select op 

((rfc-op cIs-op fwd-op ans-op los-op dat-op) 
(show-chaos-data-string pkt (select op 

(rfc-op "Contact name") 
(cIs-op "Close message") 
(fwd-op "Forward info") 
(ans-op "Answer string") 
(los-op "Loss message") 
(dat-op "Byte data") 
(otherwise NULL-s tr ing) }) ) 
; (rut-op (show-chaos-routing-packet pkt)) 
(otherwise (setq op op) ) ) ) 

(defun show-chaos-data-string ((pkt pkt) (s string)) 
(format debug- io"--X*t^A: " s) 

(loop for (i word) upfrom below (pkt-nbytes pkt) 
do (tyo (aref (pkt-data-bytes pkt) i)))) 

(defun show-chaos-routing-packet ((pkt pkt)) 
(format debug- {©"-^-X^XRout ing information:") 

(loop for (i word) upfrom 8 by 2 below (// (pkt-nbytes pkt) 2) 
do (format debug-to "•'XSubnet -^ with cost *0" 
(aref (pkt-data-words pkt) i) 
(aref (pkt-data-words pkt) (1+ i))))) 
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F:>lmach>fep>chaos-user.in.6 

;;;-*- Mode: Lii; PacKagc:Lil; Base: 8,; Lowercase: T -»- 

(include "Types-and-macros") 

{include "str ing.EXT** "chacm-ncp.EXT") 

(defatommacro do-somethmg-nasty-here * (setq junK junk)> 
:; User end of the CHAOS protocol 



(defun (address-parse uordJ ((name string) (number word)) 
{ i f (nu( i name) 
number 
nu»t*r> ) 

(defun (connect conn) ((name string) 
(number uord) 
(contact-name string) 
(uitndow-size uord) 
(timeout long)} 
(let {(real -address (address-parse name number))) 
(if {- real -address UUmOUN-CHADS- ADDRESS) 

(make-error-connectjon "Not a knouri address.") 
(let ((conn (open-connection reali-address contact-name uindow-sizs) ) ) 
(cond ( (nuJ i conn) 

(make-error-connection "Could not allocate a connection.")) 
((conn-error-conn conn) conn) 
( (progn 

(wait conn rfc-sent-state timeout "Net connect") 
(• (state conn) open-state)) 
conn) 
(T 
(progl (make-error-connection 
(select (state conn) 

(rfc-sent-state "Host not responding.") 
(ansuered-state "Received an ANS instead of an OPN.") 
(c I s-recei ved-state 
{let» ((pkt (get-next-pkt conn false)) 
(str (pkt-8tring pkt)) 
(reason 

(if (zerop (str ing- length str)) 

{progl "Host rejected connection without giving a reason, 
(return-string str)) 
str))) 
{return~pkt pkt) 
9tr)) 

(otherwise "Connection went to bad state."))) 
(remove-conn conn)))))))) 

(defun (simple pkt) ((name string) 
(number uord) 
(contact-name string) 
(timeout long)) 
(let ((real -address (address-parse name number))) 
(if (- real-address UN<NOUN-CHAOS-AODRESS} 
(make-error -pkt "Not a known address.") 
(let ((conn (open-connection real -address contact-name 1))) 
(cond ( (nul I coon) 

(make-error-pkt "Could not allocate a connection.")) 
((conn-error-conn conn) 
(progl (make-error-pkt (conn-error-message conn)) 

(setf (conn-error-message conn) NULL-string) 
(remove-conn conn))) 
((progn (wait conn rfc-sent-state timeout "Net simple") 
(- (state conn) answercd-state)) 
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(progl (get-next-pkt conn false) 
(remove-conn conn))) 
(T 
{progl {mak.e-error-pk.t 
(select (state conn) 



(rfc-sent-state "Host not responding,') 

(c t s-rece i ved-state 
(let ((pttt (get-next-pkt conn false))) 
(ppogl (pkt-etring pkt) 

{peturn-pkt pkt)))) 
(open-state "Received an OPN instead of an ANS.") 
(otherwise "Connection went into a bad state."))) 
(remove-conn conn)))))))) 



Server functions. 



(defun (listen conn) ( (contact-nanie string) 
(window-size word) 
(wai t-for-rfc boole?) 
(let ( (conn (make-connection)) 
(pkt (at locate-pkt))) 
(if (or (nul I conn) (nul I pkt) ) 

(progn (if (not (null conn)) (pcmove-conn conn)) 
(if (not (null pkt)) (return-pkt pkt)) 
NULL-conn) 
(set f ( I oca i -w i ndou-s i ze conn) w i ndow-s i ze) 
(set-pkt-string pkt contact-name) 
(send-I tsten-pkt conn pkt) 
(if (and wait-for-rfc (■ (state conn) listening-state)) 

(wait conn I tstening-state UAIT-F(3R£VER "Net Listen")) 
conn) ) ) 

(defun accept ((conn conn)) 

(if (■ (state conn) rfc-recei ved-state) 

(progn (if (not (null (read-pkts conn))) 

(peturn-pkt (get-next-pkt conn false))) 
(let (<pkt (ai locate-pkt))) 
(setf (state conn) open-state) 
(setf (time-last-received conn) TlflE) 
(setf (pkt-opcode pkt) opn-op) 
(setf (pkt-nbytes pkt) 4) 

(setf (pkt-second-data-word pkt) (I oca I -window-size conn)) 
(setf (pkt-f irst-data-word pkt) (pkt-num-read conn)) 
(transmi t-nomal-pkt conn pkt true))) 
do-some th i ng-nas ty-here 
)) 

(defun reject ((conn conn) (reason string)) 
(if (» (state conn) rfc-recei ved-state) 

(close conn reason) 
do-somethi ng-nas ty-here 
) 
(remove-conn conn)) 

(defun answer-string ( (cann conn) (answer string)) 
(if (- (state conn) rfc-recei ved-state) 
(let ((pkt (at locate-pkt))) 
(set-pkt-string pkt answer) 
(setf (pkt-opcode pkt) ans-op) 
(transmi t-normal -pkt conn pkt false)) 
do-somethi ng-nasty-here 
) 
(remove-conn conn)) 

(defun answer ((conn conn) (pkt pkt)) 
(if (■ (state conn) rfc-recei ved-state) 
(progn (setf (pkt-opcode pkt) ans-op) 

(transmi t-normal -pkt conn pkt fa/se)) 
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do-8omething-n3aty-her« '' 
) 
(rcmovc-conn conn)) 

(defun forward ((conn conn) (pkt pkt) (host uord) ) 
(if (• (state conn) pfc-received-state) 
(ppogn (setf (pkt-opcode pkt) fwd-op) 
(setf (pkt-acK-num pkt) host) 
(transmi t-normai-pkt conn pkt false)) 
do-something-nasty*here 
) 
(remove-conn conn)) 

(defun close ((conn conn) (reason string))^ 
(selTcTTstate conn) 

(Irfc-received-state open-state) 
(let ((pkt (aMocate-pkt))) 
(setf (pkt-apcode pkt) cfa-op) 
(set-pkt-str ing pkt reason) 
(transmi t-nor»al-pKt cann pkt false)))) 
(rewove-conn conn)) 
(defun (open-connect ton conn) ({»ddress uord) 

(contact-na«e string) 
(windou-size word)) 
(let ((conn (wake-connection)) 
(pkt (al locate-pkt))) 
(if (or (nut! conn) (null pkt>> 

(progn (if (not (null conn)) (renove-conn conn)) 
(if (not (null pkt)) (return-pkt pkti) 
NULL-conn} 
(setf ( I oca ^ -window-size conn) («ax 1 (ain window- size aaxinuffi-window-size) ) ) 
(setf (foreJgn-address conn) address) 
(temporary (setq junk }unk) 

leetf (contact-name conn) (copy-string contact-name))) 

(setf (pkt-opcode pkt) rfc-op) 
(eet-pkt-str ing pkt contact-name) 
(setf (pkt-dest-address pkt) address) 

(transifri t-nor«al-pkt conn pkt true) 
(setf (state conn) rfc-scnt-state) 
(setf (ti«e- last-received conn) TirE) 
conn) ) ) 

(defun (wait boole) ((conn conn) (old-state connection-state) 
(timeout long) (w/io-atate string)) 
(let (((final-time Jong) il< (« timeout UAIT-FOREVER) 

FOREVER 
(+ TinE-as-long timeout)))) 
(loop if (•• (state conn) old-state) 
return true 

if (i TinE-as-!ong final-time) 
return false 
do (process-wait uho-state #*waitl 

conn (long (coerce byte old-state)) f inat-t ime) ) ) ) 

(defun (waitl boole) ((conn conn) 

(old-state long) 
(final -time long)) 
(or im (state conn) (coerce connection-state (byte old-state))) 
(i TlHE-a s-lon g f inal-t ime) ) ) 
(defun (chaos-stream- input-avai lab I e-p boole) Hconn conn)) 
(or (not (null (stream-tnput-pkt conn))) 
(loop unless (get-next-pkt-ok? conn) 
return false 

as (pkt pkt) • (get-next-pkt conn true) 
if (nul I pkt) 
return true 
if (or (zerop (pkt-nbytes pktU 

(not (bit-test (byte 288) (pkt-opcode pkt)))) 
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do (return-pkt pkt) ~~~ ^ 

else do 

(setf (stream-input-pkt conn) pkt) 

(return true) ) ) ) 

<defun (chao9"tyi-eof byte) ((streaffl chaos-etream) (eof-option boole node ref)) 
(setq eof-option false) 
(let ( { (conn conn) ) 
{(pkt pkt))) 
(i f (or (nul I stream) 

(null (setq conn (conn-for-stream stream))) 
(progn (or (chaos-stream- input-avai lab! e-p conn) 

(process-wait "Chaos tyi" ^*chaos-stpeam-input-avai lable-p conn)) 
(nul! (setq pkt (stream-tnput-pkt conn))))) 
(progn (setq eof-option true) (byte -1)) 
(progl (arcf (pkt-data-bytes pkt) (gpkt-user-byte-pointer pkt)) 
(incf (gpkt-user-byte-pointer pkt)) 
(when (zerop (decf (gpkt-user-byte-count pkt))) 
(setf (stream-input-pkt conn) NULL-pkt) 

(return-pkt pktnnn _ 

(defun (chaos-stream-output-aval tab I e-p booic) ((conn conn)) 

(loop if (not (member (state conn) ' (open-state rfc-sent-state) ) ) 
return true ; i I legal ts actually true 

as (pkt pkt) - (stream-output-pkt conn) 
if (nul I pkt) 

do (setq pkt (setf (stream-output-pkt conn) (al locate-pkt) ) ) 
if (nul t pkt) 
return false 

if (> (gpkt-user-byte-count pkt) Q) 
return true 

unless (send-pkt-ok? conn) 
return false 

do (setf (stream-output-pkt conn) MJLL-pkt) 
(send-pkt conn pkt dat-op))) 

(defun chaos-tyo ((stream chaos-stream) (char byte)) 
(unless (nul I stream) 
( incf (x-pos stream) ) 
(let ((conn (conn-for-stream stream))) 
(unless (nut I conn) 

(or (chaos-stream-output-avai (able-p conn) 

(process-wait "Chaos tyo" ^'chaos-stream-output-avat lable-p conn)) 
(let ((pkt fstream-output-pkt conn))) 

(when (and (member (state conn) '(open-state rfc-sent-state)) 
(not (nul t pkt)) 

(> (gpkt-user-byte-count pkt) 0)) 
(setf (aref (pkt-data-bytes pkt) (gpkt-user-byte-pointer pkt)) char) 
(incf (gpkt-user-byte-pointer pkt)) 
(decf (gpkt-user-byte-count pkt)) 
(incf (pkt-nbytes pkt)) 
)))))) 
(defun (chaos-make-strsam stream) ((conn conn)) 

(let ((stream (coerce chaos-stream (al (ocate-stream (type-size chaos-stream-type) ) ))) 
(unless (nul I streaml 
(set-fields stream 

for-tyo #* chaos-tyo 
for-tyj-eof tf*chao9-ty i-eof 
for-ty I -no-hang tf' chaos- tyi -no-hang 
for-close #* chaos-stream-close 

for-terpr i-or-fresh-1 ine ff'chaos-stream-terpr i-or-fresh- I tne 
conn-for-stream conn 
character-set cscs-lispra 
)) 
(coerce stream stream))) 

(defun (chaos-tyi -no-hang boole) ((stream chaos-stream)) 
(or (nul ! stream) 

(let ( (conn (conn-for-stream stream) ) ) 
(or (nul I conn) 

(chaos-stream-input-avai labte-p conn) )))) 
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(defun chaos-stpeam-cto«e ( (stream chaos-stream) ) 
(unless (nul I stpeam) 

(let {(conn (conn-for-strea* stream))) 
.(setf (conn-for-stream stream) NULL-conn) 
(remove-conn conn)))) 

(defun chaos-stream-terpri-or-fresh-l ine ((stream chaos-stream) (aluays-terpr i? boole)) 
(unless (nul I stream) 

(uhen (or always-terpr t? im (x-pos stream) 2)) 
(incf (g-pos stream)) 
(setf (x-pos stream) 0) 
(select (character-set stream) 

(cscs-lispm (chaos-tyo stream #\cr)) 
(cscs-supdup (chaos-tyo stream #o297)) ;XTDCRL 
(cscs-telnct (chaos-tyo stream ^ol5) 

(chaos-ty o str eam j;f ol2)))))) 

;;;-«- Mode: Lri; Fackage:L(l; Base:S. ; Louercase: T -»- 

(include "Types-and-macros") • 

(include "str ing.EXT" •'netuork.EXT** "chaos-ncp^EXT" "chaos-user. EXT") 

(defun status-server 

(let ((string (make-string 488.))) 
(i f (not (nul t string) ) 
(progn 

(loop with (host-name string) - (cstring "SSK Development") 
for (i word) upfrom 9 below (string-length host-name) 
until (i i 32.) 
do (setf (aref (string-bytes string) 1) 

(aref (etring-oytes host-name) i)) 
final ty 

(loop for (? word) upfrom i below 32. 

do (setf (aref (string-bytes string) i) 8)) 
(setf (string-length string) 32.)) 
(loop with (si word) • (string- length string) 

for (i word) upfrom 8 below n-genera I -drivers 
as idrw general -driver) • (aref driver- table i) 
if (and (not (nul 1 drv)) 

(•• (send-a-chaos-packet drv) #'cant-send-a-chaos-packet)) 
do 

(setf (aref (string-bytes string) (+ si 8)) 

(byte (chaos-subnet drv))) 
(setf (aref (string-bytes string) (+ si D) 1) 
(setf (aref (string-bytes string) (+ si 2)) IB.) 
(setf (aref (string-bytes string) (+ si 3)) 8) 
(setq si (+ si 4)) 
<^. (loop for field in ' (packets-in packets-out packets-aborted 

packets- lost packets-crc-error 
packets-ram-error 
packets-bi tc-error 
packets-other-reject) 
col lect 
•(setq si (status-server-put-long 

string si (, field (gdrv-stati sties drv)))) 
into setqs 

finally (return * (progn ••setqs))) 
final ty 

(setf (str ing- length string) si) 
(fast-answer-string (cstring "STATUS") string) 
(return-string string)))))) 

(defun (status-server-put-^ong word) ((etrtng string) (si word) (val long)) 
(loop for (i word) upfrom 8 below 4 

for (v long) - val then ( I shr v 8) 

do (setf (aref (string-bytes string) (-t- si i)) (bute v) ) ) 
(+ si 4)) 

(defun uptime-server 

(let ((string (make-string 4))) 
(if (not (null string)) 
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(progn (loop for {i word) upfrom below 4 

for (t long) - (coerce Jong TlflE) then (Ishr t 8) 
do (self (aref (string-bytes string) i) (byte t))) 

(fast-ansuer-string Icstring "UPTIME") string) 

(return-string string))))) 

(defun no-te Inet-or-supdup-server 

(let ((reason (cstring "Remote login to the 6S< development system??"))) 
(fast-reject-string (cstring "TELNET") reason) 
(fast-reject-string (cstring "SUPDUP") reason) 
)) 

(defun forwardrng-name-server () 

(fast-forward-string (cstring "NAME") (cstring "NAHE") 17402)) 

(defun echo-server 

(process-run-function (cstring "Echo Server") <f'echo-server-l) ) 

(defun echo-server-1 i) 

(let ((conn (listen (cstring "ECHO") 3 true))) 
(unless (nul I conn) 

(if (null (conn-error-«essage conn)) 
(progn 

(accept conn) 

(loop for (pkt pkt) • (get-next-pkt conn false) 

if (or (null pkt) (not (null (pkt-error pkt) ) ? ) 
do (if (not (null pkt)) (return-pkt pkt)) 

(return) 
while (send-pkt conn pkt dat-op))) 
(reraove-conn conn))))) 

(de fun for ward i ng-supdup-server 

(process-run-function (cstring "FSUPDUP Server") #' fsupdup-server-l) ) 
(defun fsupdup-server-1 () ^ 

(iet« ((connl (listen (cstring "SUPDUP") 3 true)) 
(conn2 (connect 

NULL-string 1448 
(cstring "SUPDUP") 3 
'(* 68. 18. 18.)))) 
(tf (and (not (null connl)) 

(not (conn-error-conn connl)) 
(not (nul I conn2)) 
(not (conn-error-conn conn2) ) ) 
(loop initially (accept connl) 

with (pktl pkt) - NULL-pkt 
with (pkt2 pkt) • NULL-pkt 
while (and (- (state connl) open-state) 
(- (state connZ) open-state)) 
if (null pktl) do (setq pktl (get-next-pkt connl true)) 
If null pkt2) do (setq pkt2 (get-next-pkt conn2 true)) 
do (cond ((nu! I pktl)) 

((not (null (pkt-error pktl))) 
(return-pkt pktl) 
(setq pktl NULL-pkt)) 
((may-transmit conn2) 
(send-pKt conn2 pktl (pkt-opcode pktl)) 
(setq pktl NULL-pkt))) 
(cond ((nul I pkt2)) 

((not (null (pkt-error pkt2))) 
(return-pkt pkt2) 
(setq pkt2 NULL-pkt)} 
((may-transmit connl) 
(send-pkt connl pkt2 (pkt-opcode pkt2)) 
(setq pkt2 NULL-pkt))) 
do (process-sleep G0.) 

finally (if (not (null pktl)) (return-pkt pktl)) 
(if (not (null pkt2)) (return-pkt pkt2)) 

(if (not (null connl 1) (remove-conn connl) ) 
(if (not (null conn2) ) (remove-conn cann2n 
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(defun dump-rout ing- tab ie-9crver 
(let ({string (nake-string 448.))) 
(i f (not (nul I string)) 
, (loop for (i uord) upfrom below wax-subnet 
for (j word) upfrom by 4 

do (setf (aref (string-bytes string) (+ j 0)) 
(byte (aref routing-table i))) 
(setf (aref (string-bytes string) (+ j 1)) 

(byte (tshr (aref routing-table i) 8))) 
(setf (aref (string-bytes string) (+ j 2)) 

(byte (aref cost-table i))) 
(setf (aref (string-bytes string) (+ j 3)) 
(byte (Ishr (aref cost-table t) 8))) 
final ly 

(setf (string- length string) j) 
(fast-ansuer-string "DUnP-ROUTING-TABLE" string) 
(return-string string) 
) ) ) ) 

;;;-«- Hode: Li I; PacJcage:Li I : BaserS.; Lowercase: T -«- 

(include "Types-and-macros") 
(include "fsn.EXT" "str ing-EXt*) 

(external Xtssue-di sk-page-read ((dp disk-page))) 
(external Xi ssue-di sk-page-wr t te ((dp disk-page))) 

(defun t nit-disk 

(setq disk-page-i-ist NULL-disk-page) 

(defun (disk-sJpw-\ long) ((dividend long) (divisor long)) 

(word (riisk-slow-//-\ dividend divisor false))) 
(defun (disk-slow-// long) {(dividend long) (divisor long)) 

{disk-slow-//-\ dividend divisor true)) 

(defun (dtsk-slou-//-\ long) ((dividend long) (divisor Jong} (rgturn-f^uot ient boo!c)) 
(loop with (quotient long) - 8 

with (remainder long) ■ dividend 

for (subtracter long) first divisor then (Ishr subtracter 1) 
for (bit long) 

first (loop for (bit long) first 1 then (progn (setq subtracter (ishi subtracter D) 

(IshI bit 1)) 
while (< subtracter dividend) 
final ly (return bit)) 
then (Ishr bit 1) 
until (< remainder divisor) 
whi le (•- bit 0) 
when (< subtracter remainder) 
do (setq remainder (- remainder subtracter)) 

(setq quotient (+ quotient bit)) 
finally (return (if return-quotient quotient remainder)))) 

(defun (disk-slow-* long) ((a long) (b long)) 
(loop with (ans long) « 
when (bit-test a 1) 
do (setq ans (+ ans b)) 
unt i I (zerop a) 
do (setq a (Ishr a 1)) 
(setq b (IshI b 1)) 
final ly (return ans))) 



Ground up approach at first 



(defun (allocate-disk-data-raw disk^datd) {) 

(coerce disk-data (fsM-atlocate page-size))) 
(defun return-dtsk-data-rau ( (dd disk-data)) 

(unless (null dd) (fs«-free (coerce long dd)))) 

(defun (al !ocate*disk-page-r3u disk-page) 

(coerce disk-page (fsw-al locate (type-size disk-page-type)))) 
(defun return-disk-page-raw ((dp disk-page)) 

(unless (null dp) (fsn-free (coerce long dp)))) 
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(dcfun <al locate-f i le-8trean-rau file-stream) 

{coerce fiie-»treaa (fsm-a I locate (type-size file-stream-type)))) 
(defun return-f i le-stream-rau ((fs file-stream)) 

(unless (nul I fs) (fsm-free (coerce long fs)))) 



One level up, not so rau 



(def li laacro al locate-disk-data (> * (aUocate-disk-data-rau)) 
(deftilaacro return-disk-data (dd) * (rcturn-disK-data-rau ,dd)) 

(defun (atlocate-disk-page disk-page) ((disk-unit uord) (dpn long) 

(header- type long)) 
(let ((dp (at locate-disk-page-rau))) 
(unless (nul f dp) 
(set-fields dp 

error-nessage NULL-string 
disk-unit disk-unit 
dpn dpn 
usage-count 1 
page-state ps-read 
page-needs-writing false 
header-type header-type 
disk-data NULL-disk-data) 
(uithout- interrupts 

(setf (next-disk-page- 1 ink dp) disk-page-l ist) 
(setq disk-page-l ist dp))) 
dp)) 

(defun (al locate-disk-page-preload disk-page) ((disk-unit uord) 

(dpn long) 
(header-type long)) 
(let ((dp (al locate-disk-page disk-unit dpn header-type))) 
(unless (null dp) (ensure-disk-data dp)) 

(defun (al locate-disk-page-for-wri te disk-page) ((disk-unit word) 

(dpn long) 
(header-type long)) 
(let Udp (al locate-disk-page disk-unit dpn header-type))) 
(unless (null dp) (setf (page-state dp) ps-write)) 
dp)) 

(defun (al locate-disk-page-for-wri te-preload disk-page) ((disk-unit word) 

(dpn long) 
(header-type long)) 
(let ((dp (at locate-disk-page-for-write disk-unit dpn header-type))) 
(unless (null dp) (ensure-di sk-data dp) ) 
dp)) 

(defun return-disk-page ((dp disk-page)) 
(unless (nut I dp) 

(if (- (page-state dp) ps-write) 

(fcrce-di£k-page dp)) ; force a write 

(if (zerop (decf (usage-count dp))) 
(loop for (dpp di sk-page-ptr) 

- (make-pointer disk-page-ptr disk-page-list) 
then (make-pointer disk-page-ptr 

Inext-disk-page-l ink maybe-dp)) 
33 (maybe-dp disk-page) - mdpp 
until (« dp maybe-dp) 

finally (setf •dpp (next-di sk-page-l ink maybe-dp)) 
(return-di sK-data (disk-data dp)) 
(return-disk-page-raw dp))))) 

(defun force-disk-page ((dp disk-page)) 
(when (and (not (nul 1 dp)) 

(null (error-message dp)) 
(« (page-state dp) ps-write) 

(page-needs-wr i t fng dp) 
(not (nul) (disk-data dp)))) 
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(Xissue-disk-page-upi t€ dp J 
(se tf (page-needs-uir i ting dp) false))) 
<dcfun (al !oc3te-f i le-atreaa fUe-stpeamJ 
(let ((fs (a! tocate-f i le-9treaffi-raw))) 
<unfess (nut 1 fs) 
(set-fields fs 

error-message NULL-strtng 

filename (cfitename "..S") 

mode dm-block 

direction dd-read 

dtsK-uni t 8 

f t le-header-dpn -1 

file-header-page NLTLL-disk-page 

infer ior-page-map-dpn -1 

i nf er i or-page-map-page NULL-d i sk-page 

current-dpn -1 

current-disk-page NULL-d isk-page 

current-biock-numbcr 

desired-block-number 6 

currcnt-byte-of fset 

current-mode-offset 

)) 
fs)) 

(defun (error-f i le-strcam frie-stream) ((error-message string)) 
(let ((fs (aliocate-fi le-stream))) 
(if (not (null fs)) 

(setf (error-message fs) error-message)) 
fs)) 

(defun return-fi le-stream ((fs f i le-ttream) ) 
(unless (nul I f s) 

;;; needs more uork. Fix output close to fix directory 

(unless (null (error-message fs)) (return-string (error-message fs))) 

(unless (null <f i ie-header-page fs)) (return-disk-page (file-header-page fs))) 

(unless (null (inferior-page-map-page f s) ) 

(re turn-d isk-page ( infer i or-page-map-page fs))) 
(unless (null (currcnt-di sk-page fs)) 

(return-disk-page (current-disk-page fs))) 
(return-fi le-strcam-rau fs) 
)) 
(defun (ensure-di sk-data boole) ((dp disk-page)) 
(and (not (nul t dp) ) 

(null (error-message dp)) 

(or (not inuW (di sk-data dp))) 

(and (not (null (setf (disk-data dp) (al focate-di sk-data) )) ) 
(progn 

(select (page-state dp) 
(ps-read 

(Xissue-disk-page-read dp)) 
(ps-wr i te 
(loop with (dd disk-data) « (disk-data dp) 
for (i word) 

up from belou (// page-size (type-size long)) 
do (setf (aref (disk-data-longs dd) i) 0)))) 
true))))) 

(defun (ensure-header-data boole) ((fs file-stream)) 
(and (ensure-header-page fs) 

(ensure-di sk-data (f i Ie-header-page fs)) 
)) 

(defun (ensure-header-page boolel ((fs file-stream)) 
(and (not (nul t fs)) 

(null (err or -message fsll 

(or (not (null If i ie-header-page fs))) 

(not (null (setf (ft Ie-header-page fa) 

(find-dpn (disk-unit fs) (f i le-header-dpn fs) 
(header-type-to- long "FEFS") ) ) ) ) ) 
)) 
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(defun {ensure-data-page boole) ((fs f rie-streara) ) ^ 
(and (ensure-header-data fs) 

(progn (when (« (current-byte-offset fs) page-data-size) 
(incf (desipcd-b lock-number fs)) 
(set-fields fs 

current-byte-offset 
current-mode-of fset 
)) 
(when (* (current-block-number fs) (desired-b lock-number fs)) 
(uhen (not (null (current-disk-page fs))) 

(return-disk-page (current-disk-page fs))) 
(set-fields fs 

current-disk-page NULL-di sk-page 
current-block-number (desired-b lock-number fs))) 
true) 
(or (not (null (current-disk-page fs))) 

(let ((dpn (dpn (dic-for-block fs (current-b lock-number fs))))) 
(and im dpn -1) 

(not (null (setf (current-disk-page fs) 

(find-dpn (disk-unit fs) dpn 

(header-type-to- long "DATA")))))))) 
(ensure-disk-data (current-disk-page fs)) 
)) 



(defun (find-DPN disk-pagel ((disk-un\t word) (dpn iong) (header- type long)) 
(loop for (dp-- di sk-page) - di sk-page- i i st then (next-di sk-page- r»nk dp) 
If (nul I dp) 
return 

(al locate-di sk-page disk-unit dpn header-type) 
if (and (• disk-unit (disk-unit dp)) 

(- dpn (dpn dp) ) ) 
return (progn (incf (usage-count dp)) 
dp))) 

(defun (get-LABL-block disk-page) 

(let ((dp (find-DPN (header-type-to-long •LABL")))) 
(unless (null dp) (ensure-disk-data dp)) 
dp) ) 

(defun (get-root-directory file-stream) 
(let* Hfs NULL-ff le-stream) 
(lab I NULL-d»sK-page> 
(lab I -page NULL-di sk-LABD) 
(unless (null (setq (abl (get-LABL-block))) 

(unless (null (setq tabl-page (disk-LABL tabi))) 
(unless (null (setq fs (at locate-f i le-stream) ) ) 
(set-fields fs 

filename (cftlename "ROOT-DIRECTORY.DIR.l") 
Mode dm-block 
direction dd-read 
di Sk-uni t 

f i I e- header -dpn (<-8long (dpn-of-root-di rectory I abl -page) ) 
)))) 
(unless (nul I labl ) (return-disk-page labl) ) 
fs)) 

(defun (make-d&c dpn-and-count) ((dpn long) (count long)) 
(let (((d&c dpn-and-count))) 
(set-fields d&c 

dpn dpn 
count count) 
d&c)) 

(defun (d&c-for-block dpn-and-countS <<fs fiie-stream) (page-offset long)) 
(if (ensure-header-page fs) 

(d&c-for-btock-from-FEPF fs (file-header-page fs) page-offset) 
(make-d&c -1 0))) 
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{defun {dic-for-blcck-fPom-FEPF dpn-and-count) ((fs file-stream) 

(fepf*page disk-page) 
(offset long)) 
(ensure-disk-data fepf-oage) 
(let ((fepf (disk-fepf fepf-page)) 

(offset offset)) ;avoid compiler misfeature 

(if (nul I fepf) 
(make-d&c -1 0} 
(loop for (i word) upfront belou (uord (<-slong (number-of-entr ies fepf))) 
as (npages long) • (<-8long (npages (aref (page-map fepf) i))) 
as (npages-only long) > (logand npages npages-mask) 
if (< offset npages-only) 

return (let ( (dpn (<-slong (dpn (aref (page-map fepf) i))))) 
(if (not (pmap? npages)) 

(make-d&c i+ offset dpn) (- npages-only offset)) 
(ensure- infer ior-pmap fs dpn) 
(d&c- f or-b I ock-f rom-FEPF 
fs (infer tor-page-map-page fs) offset))) 
dc (setq offset (- offset npages-only)) 
finally (return (make-d4c -1 0)))))) 

(jdefun ensure- infer ior-pmap ((fs file-stream) (dpn long)) 
(when (•• dpn (infer ior-page-map-afpn fsfl 

(if (not (nul! ( Infep ior-page-map-page fs>J) 

(return-dtsk-page (inferior-page-map-page fs))) 
(setf (inferior-page-map-dpn fs) dpn) 
(setf (inferfor-page-map-page fsl 

(find-DPN (disk-unit fs) dpn (hcader-type-to-long "FEPF"))))) 



;current-byte-of fset in dm-3Bbit mode points to byte with least 
; significant byte of datum in it. Values go as 0, 4, 3., 13., . 



(defun set-f i lepos-and-R*ode ((fs fife-stream) (filepos long) (mode disk-mode)) 
(unless (nul I fs) 

(when (null (error-message fs)) 

(tet» ((item-size (word (select mode 

( (dm-character dm-byte) 8.) 
(dm-word 16.) 
(dm- long 32.) 
(dm-36bit 3B.) 
(dm-btock (* 25S. 3B.))))) 
(bi ts-per-page (* (type-size (disk-data-bytes disk-data)) 8)) 
(i tems-per-page (// bi ts-per-page item-size)) 
(block-num (disk-slow-// filepos i tems-per-page)) 
(mode-offset (word (disk-slow-\ filepos i tems-per-page) ) ) 
(byte-offset (// (« mode-offset item-size) 8))) ;work8 for dm-3Bbit!! 
(set-fields fs 

mode node 

dest red-block-number block-num 
current-modc-of f set mode-offset 
current-byte-offset byte-offset) ) ) ) ) 

(defun set-f i lepos-relattve ((fs file-stream) (relative-f i lepos long) (mode disk-mode)) 
(set-f i lepos-and-mode fs U (read-f i tepos fs node) retatlve-f i tepos) mode)) 

(defun (read-f i lepos long) ((fs file-stream) (mode disk-mode)) 
(if (and (not (null fs)) (null (error-message fs))) 
(iet» ((item-size (word (select mode 

((dm-character dm-byte) 8.) 
(dm-word IB.) 
(dm- long 32.) 
(dm-36bit 36.) 
(dm-block (« 256. 3B.))))) 
(bi ts-per-page (« (type-size (disk-data-bytes disk-data)) 8)) 
(i tems-per-page (// bi ts-per-page item-size))) 
(+ (disk-slow-* (desired-b lock-number fs) i tems-per-page) 
(current-mode-offset fs))) 
0)) 
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(defun <get-next-page disk-page) ((fs file-stream)) 
(if (ensure-data-page fs) 

(progn (setf (current-byte-of f set fs) page-data-size) 
(setf (current-mode-offset fs) 1) 
(current-di sk-page fs)) 
NULL-disk-page)) 

(defun (disk-tyi-8 byte) ({fs file-stream)) 
(if tensure-dats-page fs) 

(ppogl (aref (disk-data-bytes (disk-data (current-di sk-page fs))) 
(current-mode-o^fset fs)) 
(incf (current-mode-of f set fs)) 
(incf (current-byte-offset fs) (type-size byte))) 
-D) 

(defun (disk-tyi-16 word) ((fs file-stream)) 
(if (ensure-data-page fs) 

(progl (aref (d i sk-data-uords (disk-data (current-disk-page fs))) 
(current-fflode-of f set fs)) 
(incf (current-mode-offset fs)) 
(incf (current-byte-offset fs) (type-size word))) 
-D) 



(defun (disk-tyr-32 long) ((fs file-stream)) 
(if (ensure-data-page fs) 

(prcgl (<-slong (aref (di sk-data-s longs (disk-data (current-disk-page fs))) 
(current-mode-of fset fs))) ~ 

( incf (current-mode-of f set f s) ) 
( i ncf (current-byte-of f set f s) ( type-s i ze \ ong) ) ) 



-D) 

(defun (di«k-tyi-3B-data long) ((fs file-stream)) 
(data (disk-tyi-3B fs))) 

(deftype d»«k-tyi-3B-4-bytes (structure 

(» (union (the-array (array byte 4)) 
(the-slong slong))))) 
(defun {disk-tyi-3B Ibus-uord) ((fs file-stream)) 
(let (((Ibu Ibus-uord))) 
(if (ensure-data-page fs) 

(let* (((dt3S-4b disk-tyi-3S-A-bytes) ) 

(dd (disk-data (current-disk-page fs))) 
(cbo (currcnt-byte-offset fs))) 
(loop for (i word) upfrom below 4 
for (cbo+i ucrd) upfrom cbo 
do (setf (aref (the-arra^- dt3S-4b) i) 

(aref (disk-data-bytes dd) cbo+i))) 
(let* ((the-long (<-sIong (the-slong dt3S-4b) ) ) 

(the-byte (aref (disk-data-bytes dd) (+ cbo 4)))) 
(if (evenp (current-node-of f set fs)) 
(progn (set-fields Ibu 

data the-long 
ecc+high the-byte) 
(incf (current-byte-offset fs) 4)) 
(progn (set-ftelds Ibw 

data (rotr (logior (logand the-long -1_4) 

(logand (long the-byte) #ol7)) 
4) 
ecc+high (rotr the-byte 4)) 
(incf (current-byte-offset fs) 5))) 
(setf (ecc+high Ibu) (logand (ecc+high Ibu) ttol7)) 
(incf (current-mode-offset fs)))) 
(set-fields Ibu 

data -1 
ecc+high -1)) 
ibu)) 
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;;;-»" Mode: Li I; Package:LiI; BaseiS.; Lowercase: T -«- 

(include "Types-and-«acros") 
(include "str ing.EXT" *'di5K-raw.EXT") 

(defun (val id-pathna»e? boo\ej" lUUename string)) 
(let ((fl (string-length filename)) 

((entry word) ) ((name-type word)) ((type-ver word))) 
(and (not (nuil fitename)) 

(a (string-length f i iename) 4) 

(« (aref (string-bytes filename) 0) U/>) 

(progn (setq entry (str ing-revcrse-search-char U/> filename f! 0)) 

(k (setq name-type (str tng-seapch-char U/. filename (1+ entry) f!)) 
STRING-SEARCH-FA I LEO)) 
(ppogn 

(setq type-ver (string-search-char U/, filename (1+ name- type) fl)) 
(or (« type-ver STRING-SEARCH-FAILED) 

( I cop for ( t word) upf rom (1+ type-ver) be I ow f I 

as (char byte) - (aref (string-bytes filename) i) 
always (and (i char M/Z) (s char U/S)))) 
)))) 

(defun (open-fite file-stream) ((filename string) (dm disk-mode) (dd disk-direction)) 
(if (no t ( va I i d-pa thname? f i f ename) > 

(error-f i te-stream (cstrmg "I I legal filename.')) 
(let* ((entry (1+ (string-reverse-search-char U/> filename entire-string 8))) 
(dir (open-dir filename entry))) 
(if (not (null (error-message dir))) 

dir ;already has the error message in it 

(open-f i le-wi thin-dir dir true 

filename entry (string-length filename) 
dm dd))))) 

(defun (open-f i le-wi thin-dir file-stream) ((dir file-stream) 

(c I ose-di r-when-f i ni shed? boo I e) 
(f i lename str ing) 
(entry word) 
(end word) 
(dm disk-mode) 
(dd disk-direction)) 
(tet» ((first-dot (str tng-search-char U/^ filename entry end)) 

(second-dot (string-search-char U/. filename (1+ first-dot) end)) 
(version (if (- second-dot STRING-SEARCH-FAILED) 
(word 0) 
(str ing-to-based-numbcr filename (1+ second-dot) end 10,)))) 
(if (- second-dot STRING-SEARCH-FAILED) (setq second-dot end)) 
(open-entry-wi thin-dir dir close-dir-when-f ini shed? 
filename entry first-dot 
filename (1+ first-dot) second-dot 
version 
dm dd 
))) 

(defun (open-entry-wi thin-dir file-stream) ((dir file-stream) 

(c I ose-d i r-when-f i n i shed? boo I e) 
(entry-name string) 
(entry-beg word) 
(entry-end word) 
(type-name string) 
(type-beg word) 
(type-end word) 
(version long) 
(dm disk-mode) 
(dd disk-direction)) 
(let* ((dpn (get-entry-info dir 

entry-name entry-beg entry-end 
type-name type-beg type-end 
version) ) 
(fs (if (- dpn -1) 

(error-file-stream (cstring "File not found.")) 
(let ((fs (a! locate-f i le-stream))) 
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{unless (nu! ! fs) 

(set-fields fs 

epror-aessage NULL-string 
■ode dm 
direction dd 

disk-unit idisk-unit dtr) 
f ( (e-header-dpn dpn 
file-header-page NULL-disk-pago 
infer ior-page-map-dpn -1 
i nf er i or-page-map-page MULL-d i sk-page 
current-disk-page NULL-di sk-page 
current-block-number 9 
) 
<set-f 1 lepos-and-mode fs 8 dm)) 
fs)))) 
(if ciose-dir-when-f ini shed? (close-file-stream dir)) 
fe)) 

(defun (open-dir file-stream) ((filename string) (start uord) (end word)) 
(loop for (dir file-stream) • (get-root-directory) 
then (open-entry-ui thin-dir dir true 

filename this-entry next-> 

(cstring "DIR") 3 

1 

dtR-biock dd-read) 
for (this-entry word) • (1+ start) then (1+ next->) 
as (next-> word) - (string-search-char tt/> filename this-entry end) 
until (- next.> STRING-SEARCH-FAILED) 
final ly (return dir) )) 

(defun (get-entry-info long) ((dir file-stream) 

(entry-name string) 
(entry-beg word) 
(entry-end word) 
(type-name str ing) 
(type-beg word) 
(type-end word) 
(version long)) 
(temporary (setf (desired-block-number dir) 0) 

(set-file-pointer dir 0)) 
(loop with (dpn long) - -1 

with (hversion long! * -1 

with (found-jt boote) - false 

unt i I found- i t 

as (dir-page disk-page) - (get-next-page dir) 

until (or (null dir-page) (not (null (error-nessage dir-page) )) ) 

as (fepd disk-fepd) » (disk-fepd dir-page) 

do (loop until found- it 

for (i word) upfrom below (word (<-slong (nentrie* fepd))) 
as (entry-ptr FEPD-entry-ptr) - (make-pointer 

FEPD-entry-ptr 
(aref (entries fepd) i)) 
if (dir-entry-matches entry-ptr 

entry-name entry-beg entry-end 
type-name type-beg type-end 
version) 
do (cond f (• version (<-«tong (version entry-ptr))) 

(setq dpn (<-slong (header-dpn entry-ptr))) 
(setq found- it true)) 
((and (zerop version) 

(> (<-slong (version entry-ptr)) hversion)) 
(setq dpn (<-slong (header-dpn entry-ptr))) 
(setq hversion (<-8long (version entry-ptr))))) 
) 
final ly (return dpn))) 

(defliimacro char-« (a b) 
•(let* (({a byte) ,a) 
((b byte) ,b)) 
(if (and {> a fi/a) (< a tt/z)) 
(setq a {- a (- ff/a ff/A)))) 
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(if (and (> b n/a) (< b n/z)) 

(setq b (- b (- #/a «/A))}) 
(. a b))) 

(defun (dir-entry-matchc9 boole) ((ep FEPD-entry-ptr) 

(entpy-name string) 
(entry-beg word) 
(entry-end wordS 
(type-name string) 
(type-beg uord) 
(type-end word) 
(version long)) 
(and (or (zerop version) (• version (<-8long (version ep)))) 
(loop for (( word) upfrom type-beg betou type-end 

for (j word) upfrom 2 below (array-length (type ep)) 
always (char— (aref (string-bytes type-name) i) 
(aref (type ep) j))) 
(loop for (i word) upfrom entry-beg below entry-end 

for (j word) upfroa below (array- length (name ep)) 
always (char— (aref (string-bytes entry-name) i) 
(aref (name ep) j))) 
)) 

(defun close-f i le-stream ((fs file-stream)) 

(return-file-str eam fs)) ?'*'? ^^^^ 

:-«- node :68K; Package tLSER; Base:8. -«- 
;;; This it the atsenbly code for the fep hack 

? (psect prom address «fo7740e080) 
(psect code) 

(module (asm-hack psect coda address 0) 
(eKternal main) 

start (reset) rreset io 

(movel (X A06000) ra7) ;Put sp down beiow rem stack area 
(jmp natn)) 

;;;-»- Mcde: Lit; PackagetLiI; Base:S.; Lowercase: T -»- 

(include "Types-and-macros") 

(external (read-amem I bus-word) ( f 3dr long))! 
(external write-amem ((adr long) (vai i bus-word))) 

(def ine-sysconstant dtp-nil dtp-fix) 

#-BDLC (ferror "-XThese utils are for the real fep, stupid.") 

(defun (read- i ob-reg 1 ong) ( (reg I ong) ) 

(let-globally ( ( ibus-map-s/ot Ibus-map-slot-for-iob-regs) ) 
(read- Ibus- long (+ »iob-board-base* rcg)))) 

(defun wr i te-iob-reg ((reg long) (val long)) 

(let-globally ( ( ibus-map-slot ibus-map-slot-for-iob-regs)) 
(wr t te-lbus-long (+ »iob-board-base« reg) val))) 

(defun (read- I bus- long long) ( (addr long) ) 

(setq (address (aref Ibus-map Ibus-map-slot)) (1 bus-address-page addr)) 
(<-sIong (aref (aref Ibus-data Ibus-map-slot) ( Ibus-address-of fset addr)))) 

(defun (read-lbus Ibus-uord) ((addr long)) 
(let (((Ibw Ibus-word))) 

(setq (address (aref Ibus-map Ibus-map-slot)) (I bus-address-page addr)) 
(setf (data Ibw) (<-slong (aref (aref Ibus-data Ibus-map-slot) 

(Ibus-address-of fset addr)))) 
(setf (ecc-»-high Ibw) (ecc+high (aref Ibus-map Ibus-map-slot))) 
tbw)) 

(defun wri te-lbus-long ((addr long) (datum long)) 

(setq (address (aref Ibus-map tbus-map-slot) ) ( Ibus-address-page addr) ) 

(setq (ecc+high (aref Ibus-map Ibus-map-slot)) ( ! sh dtp-fix -4)) ;re3l ly dtp-fix 

(setf (aref (aref Ibus-data Ibus-taap-slot) ( Ibus-address-of fset addr)) (->slong datum))) 
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(defun wri te-lbus ( (addr long) (Ibw Ibus-uord)) 

(setq (address (aref Ibus-map Ibus-map-slot) ) ( Ibus-address-page addr}) 
(setq (ecc+high (aref tbus-map I bus-map-slot) ) (ecc+high Ibu) ) 
(setf (aref. (aref tbus-data Ibus-map-slot) (Ibus-address-of fset addr)) 
{->siong (data Ibu)))) 

(defun (lisp-nuil boole) ((val Ibus-word)) 

(and (« (!sh dtp-nil -4) (logand (ecc+high val) 3)) 
(« (logand dtp-nil 17) ( I sh (data val) -28.)))) 

(defun ( insert-odd-pari ty idng) ((va! long) (nblts long)) 
(setq val (logand vat (nake-sask nbtts))) 
(loop with (parity long) - val 

for (shift-count iong) • 1 then (+ shift-count shtft-count) 
until (i shift-count nbits) 

do (setq parity (logxor parity (ashr parity shi f t-count) ) 1 
finally (setq parity (logand 1 (logxor parity 1))) 
(return (togior val (ash I parity nbits))))) 

(defun put-odd-par i ty-on-uuord ( (uword nicro instruct ion mode ref)) 
(format t "^^efore parity -U" uuord) 
(alter microinstruction uuord parity 8) 
(format t ", with parity clear -^iJ" uuord) 
(loop uith (parity byte) ■ 1 ;odd 

for (i word) be low (array- length uuord) 
do (setq parity (logxor parity (aref uword i))) 
finally (loop repeat 3 ; log 8 (base 2) 

for (she byte) - A then (Ishr she 1) 
do (setq parity (logxor parity (Ishr parity she))) 
finally (alter microinstruction uword parity (progn parity)))) 
(format t ", finally -^* " uuord)) 

(defun (extract-field word) ( (p uord) (* word) (arry «byte-array-ptr) ) 
(loop with (first-byte word) - (// p 8.) 

uith (last-byte uord) - (// (1- (+ p «)) 8.) 

ui th (byte long) ■ 8 

for (i uord) from first-byte to last-byte 

for (bits-rotated uord) upfrom 8 by 8, 

do (setq byte (logior (logand (long (aref earry t)) #o377) 

(rotr byte 8.))) 
finally (return (uord (logand (make-mask s) 

(rot I byte (- bits-rotated (\ p 8. ))}))))} 

(defun insert-field ((p uord) (s word) (arry «byte-array-ptr) (byte long)) 
(loop for (siz word) - s then (- siz (- 8. pos) ) until (6 aiz 8) 
for (pos uord) • (\ p 8,) then 8 

for (val long) - (Ishl (long byte) (\ p 8.)) then (Ishr vat 8.) 
for (i word) upfrom (// p 8.) 

for (mask byte) • (byte (make-mask (nln siz (- 8 pos)) pos)) 
do {(format t "^^insrt p-^-o, 8«*'0, v-*o, result — ^o" pos siz val 
(setf (aref •arry i) (logior (logand (byte val) aask) 

(logand (aref ©arry i) (lognot mask)))))) 

(defun insert-uword-f ield ( (p word) Is word) (uuord »icroinstruct ion mode ref) (byte long)) 
( insert-field 
p s (coerce «byte-array-ptr (make-pointer microinstruct ion-ptr uuord)) byte)) 

(defun write-vwem ( (adr long) (val Ibus-uord)) 
(setq adr (logand adr 4^.(1- 1^28, ))) 

(cond ((< adr (temporary #ol777770808 sym: a-memory-v I rtuat -address) ) 
(wri te-lbus adr val)) 
((< adr (+ (temporary ^ol777778088 symra-memory-virtual -address) 18883)) 
(setq adr (logand 7777 adr)) 
(urite-amere adr vatJi 
)) 

(defun uri te-vmem-!ong ((adr long) (val long)) 
(ur ite-vmem adr ( long-into-lbus-uord val))) 

(defun uri te-amem- long ((adr long) (val long)) 
(ur ite-amem adr (long-into-lbus-uord val))) 
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(defun (read-vwea Ibus-uord) t (adr long)) 
(setq adr (logand adr <r. (1- 1.28,))) 

(cond ( (< adr (temporapy #ol77777B000 eym: a-«emopy-virtua I -address) ) 
(read-lbus adr)) 
((< adr {+ (temporary <fol777770800 syfcta-nemory-virtua I -address) 10039)) 
(setq adr (logand 7777 adr)) 
(read-amem adrl ) 
(t (let (((Itju Ibus-word))) 
(set-fields tbu 

data -1 
acc+high -1) 
Ibu)) 
)} 

(defun (read-amem- long long) ((adr long)) 
(data (read-anem adr))) 

;;;-«- llode: Li!; PackagcrLiI; Basc:8,5 Lowercase: T -«- 

(include "Types-and-macros") 

(defccnst hsb-chaos-address word 244A11 

(def const hsb-cthernet-address Bbytes (constant Bbytes 8 5 1)) 



;:;-»- Base: 8; Mode: Lit; Package: Li I; BaserS.; Lowercase: T -»- 

(include "Types-and-macros") 

(include "network. EXT" "ether net. EXT" "hsb-conf ig.EXT" "fep-ut i Is.EXT") 

idefvar «hsb-debug« word 0) 

(external add-once-per-scheduler-function ( (new- fun long))) 

(def ine-sy scons t ants 
Xdcr-com-readS 

XXdcr-uni t-tag 
ItCdcr-cyl inder-tag 
tSdcr-head-tag 
XXdcr-control-tag 
XXdcr-uni t 

IXdcr-command 
tXdcr-busy 

X*dcr-fcp 

tXdi sk-header-eector 
XXd i sk-header-head 
XXd i sk-header-cy 1 t nder 
XXd\ sk-header-pack 
XXd 1 sk-header-par i ty 

XXdsr-ready 
XXdsr-on-cyl inder 
XXdsr-seek-error 
XXdsr-dev i ce-check 
XXdsr-read-only 
XXdsr-address-aark 

XXdsr-state-machine-error 
XXdsr-se 1 ect-error 
XXdsr-overpun 

XXdsr-ecc-ok 
XXdsr-compare-error 
Xdsr-error-aask 
) 

; ; ; abi I \ ty 

(defvar fep-net-enabled boole true) 
idefvar fep-using-net boote false) 

; ; : usage 

(defvar hsb-in-use boole false) 

;;; ownership 

(def type who-has-hsb (enumeration nobody-has-hsb 

disk-has-hsb 

net-xmi t-has-hsb 

net-recv-has-hsb 

outside-has-hsb) ) 
(defvar who-has-hsb uho-has-hsb nobody-has-hsb) 
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;;; aesrrea ounersnip 
<defvar disk-wants-hsb booie false) 
(defvar net-xmi t-uants-hsb boote false) 
(defvar net-recv-uants-hsb boole false) 
idefvar outside-wants-hsb boole false) 

;;; for fep-dma-from-dev rce-f ini sh 
(defvar fdfd-saved-count-up boole true) 
(defvar fdfd-saved-buf fer-idx word 8) 

;;; internal disk state 

(deftype hsb-di sk-8tate (enumeration hds-uai t-for-user-request 

hds-uai t-for-seek 
hds-uai t-for-hsb-access 
hds-wa 1 1- f or-hsb-dma-comp ! ete 
)) 

(defvar hsb-di sk-state hsb-di«k-etat« hds-wai t-for-user-request) 

(deftype hsb-di sk-crror (enumeration hde-no-error 

hde-se I ec t-error 

hde-seek-error 

hde-diflk-error 

hde-bogus-di sk-header 
hde-track-out-of-sync 
hde- too-many-sec tor- tries 
hde- too-many-ecc-re tr i es 
)) 
(defvar hsb-di sk-error hsb-di sk-error hde-no-error) 

(defun init-hsb-for-dcp 
(setq «iob-board-nufflber* 16) 

(setq «iob-board-base« (Isht (long «iob-board-number») IS.)) 
(ini t-hsb-outside) 
iini t-hsb-network) 
(ini t-hsb-di sk) 
<abort-h8b-dnia- transfer) 
(setq hsb-in-use false) 
(setq who-has-hsb nobody-has-hsb) 
(add-once-per-schedu I er-f unct i on W s tep-hsb) ) 

(defvar pending-outside-hsb-request-count word 8) 
(defvar «spy-bu5-avai lab I e-to-outside* boote false) 



(defun ini t-hsb-outside C) 

(setq outside-uants-hsb fafse) 



(setq pending-outs ide-hsb-request-count 8) 
(setq »5pg-bu8-avai labie-to-out8fde« false) 



(deftype hsb-netuork-dr i ver (pointer hab-netuork-dr i ver-type auto-dereference t)) 
(defatommacro NULL-hsb-network-dr iver * (make-nul l-pointer hsb-netuork-dr i ver) ) 
(deftype hsb-network-dr i ver-type 

(structure (include genera I -dr i ver-type) 

(a-structure-Bust-have-one-or-«iore-e I ementtt uord) 
)) 

(defvar thc-hsb-netuork-dr iver hsb-netuork-dr i ver NULL-hsb-netuork-dr tver) 

(defun ini t-hsb-netuork O 

(f debug 1 *hsb-debug» **'«'tlni t iai izing hsb netuork driver") 
(let ((hsb-net (coerce hsb-netuork-dr iver 

(create-genera I -dr i ver 

(type-8i2e hsb-netuork-dr iver-tupe) ))) ) 
(f debug 1 *hsb-debug« "-^Xhsb netuork driver is at ^O" (coerce long hsb-net)) 
(setq the-hsb-netuork-dr iver hsb-net) 
(unless (null hsb-net) 
(set-fields hsb-net 

send-an-ethernet-packet tf* send-an-ethernet-packet-to-hsb 
send-a-chaos-packet #' send-a-chaos-packet-to-hsb 
chaos-address hsb-chaos-address 
) 
(setf •(coerce ethernet-address-ptr 

(make-pointer byte-ptr (aref (ethernet-address hsb-net) 8))) 
•(coerce ethernet-address-ptr 

(make-pointer byte-ptr (aref hsb-ethernet-address 8)))) 
(f debug 1 *hsb-debug* "'vXf ini shing hsb netuork driver") 
(f ini sh-qenera I -driver (coerce genera I -driver hsb-net)) 
(f debug 1 *hsb-debug* ''^►XHSB netuork driver initialized") 
)) 
(setq fep-net-enabled true) 
(setq fep-using-net true)) 
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{defvarAini tfun int t-hsb-di sk-globat a () 

(ongs-per-disk-page uord (// (type-size di sk-data-type) 4) 

hsb-dna-pointep-fop-disk word (- (type-size di sk-data-type) ) 

fep-hsb-di sk-page disk -page NULL-di sk-page 

fep-di sk-tr ics-untU-g'i ve-up word 32- 

hsb-countcr-di sk-start-dma fong 

hsb-countcp-f ini sh-di sk-cima long 

hsb-counter-too-many-sector-tp ies long 8 

hsb-countcp-ecc-eppops long 9 

hsb-countep-sectop-wai t-no-t tmeout long 9 

hsb-countep-scctop-n-l-found long 

) 

(defun ini t-hsb-di sk 
(ini t-hsb-di sk-globals) 
(ini t-disk-ePPOP-hi story) 

(setq hsb-disk-state hds-uai t-fop-usep-Ptquest) 
(sctq hsb-disk-erpop hde-no-eppop) 

(defun step-hsb ~ 
(select who-has-hsb 

(net-xmi t-has-hsb (steprhsb-net-xai t) ) 
(net-pecv-has-hsb (step-hsb-net-pecv))) 
(step-hsb-disk) 
(bid-fop-hsb-access) 
(uhen (and hsb-in-use 

(• uho-has-hsb net-recv-has-heb) 

(op disk-wants-hsb net-x«i t-wants-hsb outside-wants-hsbn 
(abopt-hsb-dna-tpansf cp)) 
(unless hsb-in-use ;; net-recv -> net-xnit -> disk -> net-pecv ,etc. 
(if outside-wants-hsb 
(give-hsb-to-outsideJ 
(setq «spy-bus-avai fabte-to-outsidc« false) ;outsfde doesn't want it 
(select who-has-hab 

((nobody-has-hsb net-r»cv-hat-hsb) (cond (net-xmi t-uants-hsb (give-hsb-to-net-Kmi t)) 

(disk-wants-hsb (give-hsb-to-disk)) 
(net-pecv-wants-hsb (gi ve-hsb-to-net-pecv) ) ) } 
(n«t-K»i t-has-hsb (cond (disk-wants-hsb (give-hsb-to-disk)T 

(net-pecv-uants-hsb (gi ve-hsb-to-net-pecv) ) 
(net-xiii t-wants-hsb (give-hsb-to-net-xwi t)))) 
(disk-has-hsb (cond (net-pecv-wants-hsb (gi ve-hsb-to-net-pecv) ) 

(net-xmi t-wants-hsb (gi ve-hsb-to-net-xmi t) ) 
(di sk-wants-hsb (g i ve-hsb-to-d i sk) )))))) ) 

(defun bid-fop-hsb-access () 

(setq outside-wants-hsb (> pending-outside-hsb-pequcst-count 9)) 
(setq disk-wants-hsb (and (- hsb-disk-eppop hde-no-eppop) 

(not (nul I fep-hsb-di sk-page)) 
U hsb-disk-state hds-wai t-fop-hsb-access)) ) 
(setq net-xKi t-wants-hsb isnd fep-net-enabled 

fep-using-net 

(not (null {gdpv-x«i t-l (St the-hsb-netwopk-dp i vcp) ) ))) 
(setq net-pecv-wants-hsb fep-net-enabled)) 

(defun gtve-hsb-to-outside 

(setq «5py-bus-avai Iable-to-outstde« tpue) 
(setq who-has-hsb outside-has-hsb) 
(setq hsb-in-use tPue) ) 

(defun request-spy-bus () ;Bust have watching unpequest 

( i ncf pend i ng-outs i de-hsb-request-count) ) 

(defun unpcquest-spy-bus 
(ungpab-spy-bus) ) 

(defun (gpab-spy-bus boole) ( (no-hang-p boole)) :«ust have Batching ungpab 
(incf pend i ng-outs ide-hsb-pcquest-count) 
(if (op »spy-bus-avai labie-to-outside« 
no-hang-p 

(ppogn (ppocess-wai t "Gpab spy bus" jy'gpab-spy-bus-l) 
tPue)) 
tPue 
(decf pending-outside-hsb-pequest-count) ;couldn*t get it 
false)) 

(defun (grab-spy-bus-l boole) () 
»spy-bus-ava i Tab f e- to-outs i de«) 

(defun ungpab-spy-bus () 

(when (zepop (decf pending-outside-hsb-pequest-count) ) 
(setq hsb-in-use false) 
(setq who-has-hsb nobody-has-hsb) ) ) 



4,887,235 
919 920 

(defun gi ve-hsb-to-disk 

(f debug 103383 *hsb-debug« "-tGiving HSB to disk.") 

(setq uho-has-hsb di sK-has-hsb) 

(5tep-h5b-di8k)) ;doe9 actual activation 

(defun gi ve-hsb-to-net-xmi t 

{fdebug 103333 ^hsb-debug* "^XGi ving HSB to net xwit.") 
(setq uho-has-hsb net-xmt t-has-hsb) 

(let ((pkt (get-pkt-froffl-driver-queue (coerce genera I -driver the-hsb-network-dri ver) ) ) ) 
(if (nu! f pkti 

(setq who-has-hsb nobody-has-hsb) 
(fdebug 2 *hsb-debug* 

•'^:;Found a packet to xmit on HSB Ml" 
(coerce long pkt) ) 
(net-fep-transmi t-pkt pkt)))) 

(defun give-hsb-to-net-recv 

(fdebug 100300 *hsb-debug« "-vIGWing HS3 to net rccv.") 
(setq who-has-hsb net-recv-has-hsb) 
(net-fep-recei ve-pkt)) 



Utilitiea 



(externals ( (disk-slou-\ long) long long) 
((disk-slow-// long) long iongH 

(defun disk-spy-sefect () 

(spy-write spy-net-sei ect «iob-b03rd-number3|t)) 

(defun (fep-dlek-select-uni t string) ((unit word)) 
(disk-spy-select) 
(fep-ur i te-di sk-command (dpb-i or- typed long unit tXdcr-unit 

(dpb-ior-tuDed long XXdcr-uni t-tag 

(fep-ur i te-di sk-command (dpb-i or- typed long unit IXdcr-unit 

(dpb-i or- tuoed long 1 XXdcr-uni t-tag 

(fep-ur i te-di sk-command (dpb-i or-typed long unit Itdcr-unit 

(dpb-i or- tuDcd long 1 XXdcr-uni t-tag 

(let ((sts (fep-read-disk-status)) ) 

(cond ((tdb-test-typed long Xtdsr-seiect-error sts) (cstring "Select error")) 

( (Idb-test-tuped long XXdsr-ready tts) NULL-etring) ;no string is good string 
(T (cstring ^Dr i ve not ready") ))!) 

(defun fep-wri te-di sk-command-no-fep ((val long)) 

(wr i te-iob-reg «disK-command-of fset* val)) 
(defun fep-ur i te-di sk-command ((val tongJ) 

(wr i te-iob-reg *disk-cowffiand-of f set* tdnb-i or- typed long 1 XXdcr-fep val))) 
(defun fep-ur i te-di sk-commandl ({val iong)) 

(fep-ur i te-di sk-comraand (dpb-ior-typed long «fep-disk-unt t* Xtdcr-uni t 

(dpb-i or-typed long 1 XXdcr-uni t-tag val)))) 

(defun (fep-bui Id-sector-header long) ((pack uord) (cyl uord) (head uord) (sector word)) 
(let (((header long) (dpb-ior-typed iong pack XXdi sk-header-pack 

(dpb-ior-typed long cyl XXdi sk-header-cyl inder 

(dpb-ior-typed long head XXdisk-header-head 
(dpb-ior-typed long sector 

XXd I sk-header-sector 
0)))))) 
(dpb-ior-typed long (logxor (fep-di sk-compute-par i ty32 header) 1) 
XXdi8k-header-par i ty header))) 

(defun ( fep-di sk-compute-par ttu32 long) ((n32 long)) 
(let* ((nie (logxor (word n32) (word (rotr n32 IS.)))) 
(n08 (logxor nlG ( 1 shr nl6 8))) 
(n04 (logxor n08 ( I shr n08 A))) 
(n32 (logxor n04 ( I shr n04 2))) 
(n01 (logxor n02 ( 1 shr n02 1)))) 
(logand n01 1))) 

(defatommacro n-sectors 16.) ; temp until units are table driven 

(defatommacro n-heads 10.) ;temp until units are tabic driven 
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Here for disk hacking 



(defvar hsb-disk-errop-hi stopy (array hsb-diak-errop 16,) ()) 
(defvap di sk-eppop-hi stopy-count wopd 8) 
(defupi tpii t-disk-epPOP-histopy 

(setq di sk-eppop-hi stopy-count C) 

(loop for i\ word) upfpom to 16. 

do (setf (apef hsb-disk-eppop-histopy i) hde-no-eppop) ) ) 

(defun push-di sk-erpor ( (hde hsb-dt sk-epror) ) 
(setq hsb-di sk-crror hde) 

(setf (aref hsb-disk-error-ht story (V disk-error-hi story-count 16.)) hde) 
( incf disk-eppop-hi story-count! f 

(defun fep-clear-hab-di sk-erpop 
(setq hsb-disk-eppop hde-no-error) 
(setq hsb-disk*state hds-uai t-f or -user-request)) 

(defun try-to-f ix-hsb-disk-error ; fix this later 

(unless (null fep-hsb-d» sk-page) 

(setf (error-wessage fep-hsb-di sk-page) 

(cstring "Disk error during read.")) 
(setq fep-hsb-di sk-page NULL-di sk-page) )) 

(defvar last-fep-read-disk-status long 0) 
(defun fep-check-disk-eppop () 

(let ((sts (fep-pead-disk-status))) 
(seta last-fcp-pead-disk-status sts) 
(if (bit-test Xdsp-eppop-wask sts) 

(push-d i sk-eppop hde-d i sk-eppop ) ) ) ) 

(defun step-hsb-dtsk 

(if (m hsb-di sk-cppop hde-no-eppop) 
(try-to-f ix-hsb-di sk-error) 
(select hsb-disk-state 

(hds-uai t-for-user-request (uhen (not (null fep-hsb-di sk-page) ) 

( f ep-d i sk-se I ec t-and-seek) 
(setq hsb-disk-state hds-wai t-for-seek) ) ) 
(hds-uai t-for-seek (when (fep-disk-seek-completed-ok?) 
(fep-di sk-select-head) 

(setq hsb-disk-state hds-wai t-for-hsb-access) ) ) 
(hds-wai t-for-hsb-access (when (- uho-has-hsb disk-has-hsb) 

(setq fep-disk-tr ies-unti l-give-up 32.) 
(fep-di sk-search-for-scctor-n-1) 
( f ep-d i sk-s tar t-dma) 

(setq hsb-disk-state hds-wai t-fop-hsb-dma-comp I ete) ) ) 
(hds-uai.t-fop-hsb-dma-complete 
(when { f ep-d » sk-dma-comp I ete-ok?) 
(cond ( (fep-di sk-hcader-match?) 
(fcp-f ini sh-disk-dma) 

(cond ({ldb-test XXdsr-ecc-ok (fep-pead-disk-status) ) 
(setq fep-hsb-di sk-page NULL-di sk-page 

hsb-di sk-5tate hds-wai t-for-usep-request 
hsb-in-use false)) 
( (progn (incf hsb-counter-ecc-errors) 

(zerop (decf fep-disk-tr ies-untt l-give-up)) ) 
(push-disk-error hde-too-wany-ecc-retr ies) 
(setq hsb-in-use false)) 
(T (fep-di sk-start-dma) in 
dm hsb-di sk-error hde-no-error) 

(setq hsb-in-use false)) 
((zerop (decf fep-di sk-tr ies-unti l-give-up) ) 
( i ncf hsb-counter-too-many-sector-tr i es) 
(push-disk-error hde-too-many-sector-tr ies) 
(setq hsb-in-use false)) 
(T (fep-disk-start-dma))))) ;try again 

(defvar «fep-disk-pack-id« word 0) 

(defvar «fep-di sk-uni t* word 8> 

(defvar «fep-dtsk-sect« word B) 

(defvar »fep-di sk-head« word 0) 

(defvap «fep-disk-cy/» wopd 0) 

(defvap «fep-disk-expected-headep* long 0) 

(defun fep-disk-select-and-seek 
(di sk-spy-setect) 
(let* ((dp fep-hsb-di sk-page) 
(dpn (dpn dp) ) 

(cyl-head-sect (logand dpn U.il- 1 26.))) 
(cyl-head (uopd (di sk-s low-// cyl-head-sect n-sectors) ) )) 
(setq *fep-disk-uni t» (word ( I shr dpn 25.)) 

«fep-disk-sect« (word (disk-slou-\ cyl-head-sect n-sectors)) 
»fep-disk-head« (word (disk-slow-\ cyl-head n-heads)) 
«fep-di5k-cyi« (uoPd (disk-slow-// cyl-head n-heads)) 
»fep-di8k-expected-headep« (fep-bui td-sector-header 

«f ep-d i sk-pack- i d* «f ep-d i sk-cy I « 
«fep-disk-head» «fep-di sk-sect«) 
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(fep-uri te-disk-coramand 8) 
(fep-wpi te-disk-commandl 8) 
(f*p-ur i te-di 8k-commandl 8) 

(if (Idb-test-typed long Xldsr-sclect-error {fep-read-diak-status) ) 
(push-disk-error hde-S6 I ect-error) 

(fep-ur i te-di sk-commandl «fep-d iak-cyi*) 

(fep-uir i te-di sk-coramandl (dpb-iop-typed long 1 XXdcr-cyl inder-tag *fep-disk-cy l») ) 

( fep-ur i te-di skrcomoiandl «fep-di sk-cyl*) 

))) 

(defun (fep-di sk-seek-compietcd-ok? boole) {) 
(let ((sts (fep-pead-disk-statusM) 

(if (Idd-tcst-typed long XXdsr-seek-error sts) 
(progn Ipush-di sk-error hde-seek-error) 
false) 
(Idb-test-typed long XXdsr-on-cy I inder sts)))) 

(defun fep-disk-selcct-head 

(fep-ur i te-d i sk-commandl «f ep-d i sk-head*) 

( fep-ur t te-disk-commandl (dp5-i op- typed long 1 tXdcp-head-tag «fep-di sk-head») ) 

( f ep-up i te-d i sk-commandl *f ep-d i sk-head«} 

(fcp-check-disk-eppop) ) 

(defun fep-disk-seaPch-fop-sectop-n-1 
(spy-upite spy-net-control 8) 
(locpuith (sectop-n-1 long) • (fep-bui Id-sectop-headep 

«fep-disk-pack-id* sfep-disk-cyj* 
»f ep-d i sk-head* (\ (+ »fep-di8k-sect« n-sectops -1) 
n-sectops)) 
with (n-l-low wopd? - (uopd sectop-n-l) 
with (n-l-high uord) « (woPd (potp sector-n-l 16.)) 
with (command long) - (dpb-ior (ionq »fep-disk-unit«) Itdcp-unit 

(dpb-iop I Itdcp-uni t-tag 

(dpb-iop Xdcp-com-peadS tXdcp-command 
(dpb-iop 1 Wdcp-contpol-tag 
(dpb-iop 1 XXdcp-busy 
8))))) 
repeat 32. 

until (loop initially (fep-stapt-hsb-dma-fpom-device-i»acro tpue true -2) 
(fep-wp i te-di sk-commandl command) 
repeat 258. 

when (and (bit-test (build fep-hsb-control not-spy-dma-busy 1) 
(spy-pead fep-hsb-control)) 
(ppogn ( fep-ur i te-io-uord fep-hsb-control 

(build fep-hsb-control 
wr i te-to-dev 1 
not-spy-dma-busy 8)) 
(fep-hsb-setup-macro true -2) 
(incf hsb^countcr-sector-wai t-no-t imeout) 
true)) 
return (and (« (fep-read-io-uord fep-hsb-data) n-l-lou) 
(- (fep-read-to-word fep-hsb-data) n-l-hinh) 
(progn (mcf hsb-counter-sector-n-l-found) true)) 
finally (fep-ur i te-io-uord fep-hsb-control 

(build fep-hsb-control 
wri te-to-dev 1 
not-spy-dma-busy 8)) 
(return true) jdon't waste ti«e timing out 

(defun fep-di sk-start-dma 
(spy-upite spy-net-contpol 8) 
( tnc-f hsb-countep-di sk-stapt-dma) 

(fep-stapt-hsb-dma-fpom-device tPue tPue hsb-dma-pointer-for-disk) 
(fep-ur i te-d i sk-commandl 

(dpb-iop-typed long «fep-di sk-uni t« XXdcp-unit 
(dpb-iop-typed long 1 XXdcp-uni t-tag 

(dpb-ior-typed long Xdcp-com-pead8 Itdcp-command 
(dpb-iop-typed long 1 XXdCP-contPol-tag 

(dpb-iop-typed long 1 XXdcp-busy 
81)))))) 

(defun (fep-di sk-dma-complete-ok? &oole) (J 
(and (f ep-hsb-dma-f inf 5hed?l 

(progn ( f ep- f i n i sh-hsb-dma- f rom-dev i ce) 
true))) 

(dcfvar tast-disk-actual-header long 8) 
(defun (fep-di sk-header-match? boole) 

(fep-hsb-setup tPue hsb-dma-pointep-fop-disk) 
(let* (dou-uopd (fep-pead-hsb)) 
(high-uopd (fep-pead-hsb)) 
(disk-actual-headep (dpb-iop-typed long high-wopd tfo2828 



(dpb-iop-typed long (Idb-typed long «ro8828 low-uopd) 
#o8828 8)))) 



(seta last-disk-actual-header disk-actual-header) 
(op (- disk-actual-headep *fep-di sk-expected-header*) 

(progn (cond ((Idb-test-typed long tfo2BZl disk-actual-header) 
(push-di sk-error hde-bogus-di sk-header) ) 
dm (Idb-typed long tfo2Q2B di sk-actuat -header) 

(Idb-typed long ^o388G *fep-disk-expected-header*) ) 
(push-di sk-errop hde-track-out-of-sync) ) ) 
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falfte)r)r 

(defua fep-f inish-disk-dma 

(incf hsb-counter-f ini th^disk-dma) 
(fcp-hsb-to-array (nakc-pomter ucrd^jitr 

(aref id isk.-word9 Cdisfc-data fep-hsb-df sk-page) ) 0) ) 
(* tong»-per-disk-page 2})) 



Actual natuork hacking functiona 



(defun net-spy-telect () 

(Epy-uirtte spg-net-aelect «iob-board-nu»ber«) ) 

(defun net-feD-tpans«t t-pkt ((pkt gpkt)) 

(f debug 648308 «h5b-debu9* "-XNET-FEP-TRANSniT-PICT.,.") 
(let* TClen (gpkt-transmi t-size pkt)) 
(bp (« I en -2}}) 
(net-spy-select) 
(spy-write spy-net-control 232) 
(fep-array-to-hsb-portion true (- bp 2) 

C»ake-po inter word-ptr (aref (gpkt-data-uopds pkt) -7)) 
len) 
(fep-«tapt-h5b-d«a-to-device true true bp))) 

(defun »tep-hsb-net-xmi t 
(uhen (fep-hsb-dma-f inished?) 
( f ep- f i n 1 8h-hsb-dBa- to-dev i ce) 

(return-current-output-pkt (coerce genera I -driver the-hsb-netuork-dr iver) ) 
(network-meter the-hsb-netuork-dr iver packets-out) 
(setq hsb-in-use false))) 

(defun net-fep-receive-pkt 

(f debug 818388 shsb-debug* "-XNET-FEP-RECEIVE-PKT. . . ") 

(nct-spy-seiect) 

(spy-urite spy-net-control 206) 

(spy-urite spy-net-contro! 28S) {hardware bug, need to do twice 

(fcp-start-h$b-dma-fro«-device true false 8)) 

(defun step-hsb-net-recv 
(when (fep-hsb-dma-f inished?) 

(net-fep-process-received-pkt (fep-f inish-hsb-dma-from-device)) 
(setq hsb-in-use false))) 

(defun net-fep-process-received-pkt ((size word)) 

(if (< size (+562 4B. 4)) ;iiinimat ethernet packet 

(network-meter the-hsb-network-dr iver pacKets-other-re ject) 
(let (((Sbytes 6bytes))) 

(fep-hsb-port ion-to-array true 8 

««.^«« *?o«^ce word-ptr (make-pointer byte-ptr (aref Bbytes 8))) 3) 

(f debug 884888 «hsb-debug* "-XSource read from hsb**) 
(when Tor (loop for (j word) dounfrom 5 to 8 

always (- (aref (ethernet-address the-hsb-netuork-dr iver) j) 
(aref Sbytes j))) 
(loop for (j word) upfrom 8 below 6 , 

always (- (aref Gbytes j) -1))) 
(fdebug 884888 «h5b-debug« -^tPacket for me.") 
(let* ((size (- size S 6 4)) ;don't need dst,8rc,crc 

(pkt (al locate-gpkt (- size 2)))) ; type isn't part of the allocation 
(if (nul I pkt) 

(network-meter the-hsb-network-dr iver packets-other-reject) 
(fdebug 804038 *hsb-debug« "...packet is at -^0" (coerce long pkt)) 
(fep-hsb-port ion- to-array true (+ G G) ;sk(p dst.src 

(make-pointer word-ptr (aref (gpkt-data-words pkt) -D) 
(// (1+ size) 2)) ;word count 
(fdebug 884008 «hsb-debua« 

--XNET-FEP-fi£CEl^E-PJ^T-CDNTINUED: HSB-TO-ARRAY complete.-) 
(recei ve-ethernct-packet-from-hardware 

(coerce genera I -driver the-hsb-network-dr iver) 

pkt 

(aref (gpkt-data-words pkt) -1)))))))) 



Program access to the High Speed Buffer 



(deflilmacro fep-hsb-setup-macro (count-up buffer-ldx) 
' (progn (fep-wr i te-io-word fcp-hsb-control 

(buifd fep-hsb-contro/ 
write- to-dev 1 
not-spy-dnia-buay 8 
. ^ , ^ count-up .(H count-up "Up" "Down"))) 
(fep-wr (te- 10-word fep-hsb-po inter ,buf fer-idx) ) ) 

(defun fep-hsb-setup ((count-up boole) (buffer-idx word)) 
(setq hsb-in-use true) 
(fep-hsD-se tup-macro count-up buffer-idx)) 
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(defun (fep-pcad-hsb word) 

(setq hsD-tn-use true) 

(fep-read-io-uord fep-hsb-data) ) . 
(defurf fep-uri te-hsb ((datum uord)) 

(setq hsb-tn-use true) 

(fep-ur i te-io-wopd fep-hsb-data datum)) 

(defun fep-clear-hsb 
(fep-hsb-setup true 8) 
(loop repeat 1_11, do (fep-uri te-io-uopd fep-hsb-data 0))) 

(defun fep-arpay-to-hab-portion ((count-up boole) (buffep-idx wopd) 

(appay-ptp wopd-ptp) (len uopd)) 
(setq hsb-in-use tpue) 
(fep-hsb-setup count-up buffep-idx) 
(fcp-appay-to-hsb array-ptp len)) 

(defun fep-appay-to-hsb ((appay-ptr wopd-ptp) (len uopd)) 
(setq hsb-in-use true) 

(loop with (appay-ptp uord-ptp) • arpay-ptp 
repeat len 
do (fep-ur i te-io-wopd fep-hsb-data tapray-ptp) 

(ptp-incf apray-ptr word-ptr (type-size uord)))) 

(defun fep-hsb-portion-to-array ((count-up boole) (buffer-idx uord) 

(array-ptr uord-ptr) (ten uord)) 
(setq hsb-tn-use true) 
(fep-hsb-setup count-up buffer- idx) 
(fep-hsb-to-array array-ptr len)) 

(defun fep-hsb-to-array ((array-ptr uord-ptr) (len uord)) 
(setq hsb-in-use true) 

(loop uith (array-ptr word-ptr) • array-ptr 
repeat len 

do (setf •array-ptr (fep-read-io-uord fep-hsb-data)) 
(ptr-incf array-ptr word-ptr (type-size uord)))) 



DMA hackery 



(defun (fep-hsb-dwa-f ini shed? boole) 

(bit-test (build fep-hsb-control not-apy-dma-busy 1) 
(spy-read fep-hsb-controt i H 

(defun fep-start-hsb-dma-to-device ((count-up boole) (drive-spy-dma-busy-p boole) 

fbuffer-idx word)) 
(setq hsb-in-use true) 

(f debug 000403 «hsb-debug* "-Xfep-dma-to-device* . . **) 
(fep-ur i te-io-uord fep-hsD-po inter buffer- idx) 
(fep-ur I te-to-uord fep-hsb-control (build fep-hsb-control not-spy-dma-busy 9 

dma-setup 1)) 
(fep-ur i te-io-word fep-hsb-control (build fep-hsb-control not-spy-dma-busy 

draa-setup 1 
spy-dma-enb 1 
.^ . , . «rite-to-dev 1)) 

( fep-ur I te- I o-uor d f ep-hsb-con tr o I 

(logior (build fep-hsb-control not-spy-dma-busy 

dma-setup 1 
epy-dma-enb 1 
ur I te-to-dev 1) 
(if count-up 

(build fep-hsb-control not-apy-dma-busy 8 
count-up 1) 0) 
(if dr i ve-spy-dma-busy-p 

(build fep-hsb-control not-spy-dma-busy 
drive-busy 1) 0)))) 

(defun fep-f inish-hsb-dma-to-dev(ce 
(setq hsb-in-use true) 
(fep-uri te-to-uord fep-hsb-control (build fep-hsb-control not-spy-dma-busy urite-to-dev 1))) 

(deflilmacro fep-start-hsb-dma-from-device-macro (count-up dri ve-spy-dma-busy-p buffer-idx) 
•(progn (fep-ur i te-io-uord fep-hsb-pointer U , buffer-idx (if , count-up -1 0))) 

(fep-uri te-io-uord fep-hsD-control (build fep-hsb-control not-spy-dma-busy 
,, ... , dma-setup 1)) 

(fep-ur i te- 1 o-uord f ep-hsb-contro I 

(logior (build fep-hsb-control not-spy-dma-busy 

dma-setup 1 
•py-dma-enb 1) 
(if , count-up 

(build fep-hsb-control not-apy-dma-busy 
count-up 1) 0) 
(if ,dr i ve-apy-dma-busy-p 

(build fep-hsb-control not-spy-dma-busy 
drive-busy 1) 01)))) 

(defun fep-start-hsb-dma-from-device ((count-up boole) (dri ve-apy-dma-busy-p boole) 

(buffer-idx uord)) 
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(setq hsb-in-use true) 

(fep-start-hsb-dma-from-dcv ice-macro count-up drive-spy-dma-busy-p buffep-idx) 

(setq fdfd-saved-count-up count-up) 

(setq fdfd-savcd-buf fer-idx buffer-idx)) 

(defun (fep-f inish-hsb-dma-froB-device word) 
(setq hsb-in-use true) 
(tep-ur i te-i 0-word fcp-hsb-control 

(build fep-hsb-control not-spy-dma-busy 8 urite-to-dev 1)) 
(let ((ptr (fcp-read-io-word fep-hsb-pointer) ) ) 
(logand 3777 (if fdfd-saved-count-up 

(- ptr fdfd-taved-buffer-idx -1) 
(- fdfd-«aved-buf fer-idx ptr))))) 

(defun abort-h»b-dma-transfer (l 
(setq hsb-in-use false) 
(fep-ur i te-io-uord fep-h5&-contro( 

(build fep-hsb-control not-spy-dma-busy write-to-dev 1))) 



Interface to the outside «or!d 



(defun eend-an-ethernet-pacKet-to-hsb iidrw hsb-network-dr iver) 

(pKt CP*^0 
(protocol uord) 
(addr ethernet-address-ptr)) 
(f debug 903018 «hsb-debug« "^Xscnd-an-ethernet-packet-to-heb. . .") 
(setf Taref (gpRt-data-words pkt) -1) protocol) 
Csetf •(coerce cthernet-address-ptr 

(■ake-pointer byte-ptr (aref (gpkt-data-bytee pkt) -14J)) 
•addr) 
(setf •(coerce ethernet-addrees-ptr 

(wake-pointer byte-ptr (aref (gpkt-data-bytes pkt) -08.))) 
•(coerce ethernet-address-ptr 

(nake-pointer byte-ptr (aref heb-ethernet-address 0)))) 
(setf (gpkt-transai t-size pkt) U (// (aax (l-t- (gpkt-transni t-size pkt)) 46.) 2) 

13 3)) 
(add-pkt-to-dr iver-queue pkt (coerce genera I -driver drv)) 

(external ■ake-chaoe-packet-safe ((pkt gpkt) 

(header byte-fomat) 
(data byte-for»at))) 

(defun send-a-chao8-packet-to-h8b ((drv hsb-netuork-dr iver) 

(pkt gpkt) 
(chaddr word) } 
(fdebug 000004 mhsb-debug* "*-X»end-a-chaoa-packet-to-h8b. • .") 
(■ake-chaos-packet-safe pkt bf-bytee bf-bytes) 
(let ( ( (earb ethcrnet-address-reso I ut i on-b I ock) ) ) 
(setf (aref (earb-words earb) 0) chaddr) 
(trans«i t-ethcrnet-packet (coerce genera I -driver drv) pkt 

ether-typefCHAOS earb))) 

; These vars are used to keep track of which program is currently loaded into the fep 

(defvar *fep-progra(B- loaded* ()) ;inDdu(e currently loaded 

(defvar «:fep-program~stsrt-addresa* -1) ? start address of load prog loaded 

;0n an abort, this form tries to force the fep back into the rom 
(defmacro wi th-fep-program (program 5body body) 
*(let ((.fep-program-aborted. t)) 
(unwind-protect 

(progn (assure-fep-progr am- loaded .program) 
.•body 

(setq . fep-program-aborted. ntl)) 
(if. fep-program-aborted, (force-fcp-into-rom) ) )) ) 

interface routines to the rest of the L-console system 
(defun cached-read (adr) 

(let ((number (// adr *cached-page-si2e«) ) 
(uord (\ adr nccached-page-si ze*) ) ) 
(aref (f ind-cached-page number) word))) 

(defun cached-urite (adr wal) 

(let* ((number (// adr jrcached-page-size*) J 
(uord (\ adr *cached-page-si2e*) ) 
(page (f ind-cached-page number))) 
(check-arg-type val :fix) 
(setf (aref page word) val) 
; (setf (cached-page-wr i ttenp page) t) 
vai)) 
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(defun f tush-page-cache (write-backp invalidatep) 

{loop for page being the array-eiements of «cached-page-tab!e« using (index entry) 
for page-valid * (and page (neq page 't)) 

;% for ail non-nii entrys possibly write back, possibly invalidate 
when page 

do (if (and (neq page 't) write-backp (cached-page-wr i ttenp page)) 
(swap-out-cached-page page)) 
;; Page was non-nil, see if we should invalidate it 
(setf (aref ^cached-page- table* entry) (not invalidatep)) 
;; I f we had a page, return it 

(if (neq page ' t) (deal iocate-resoupce 'cached-page page))) 
;; No good reason to do this here... It just seems appropriate, 
(if invalidatep (setq *fep-progratn- loaded* nil))) 



(defun clear-cached-page-table 

(loop for page bemg the array-elements of «cached-page- table* using (index entry) 
for page-valid « (and page (neq page 't)) 
when (and page (neq page ' t) ) 

do (deal locate-resource *cached-page page) 
do (setf (aref *cached-page-table* entry) nil))) 

(defun deal !ocate-C3ched-page-l ist (page- list) 
(loop for page in page-list 

do (deal locate-resource 'cached-page page Hi 

(defun swap-out-cached-page- I ist (page- I ist) 
(loop for page in page- I ist 

do (swap-out-cached-page page))) 

(defun col lect-cached-page-l ist 

(loop for page being the array-elements of »cached-page- table* 
when (and page (neq page 't)) collect page)) 

(defun ctear-cached-amem 

(fillarray *cached-amem* 'nil)) 

(defun swap-out-cached- amem (amem-array) 

(loop for i from 8 below (array-act i ve- length amem-array) 
for element ■ (aref amem-array i) 
when element do (write-amem i element))) 

(defun col lect-cached-amem () 

(let ((copy (make-array (array-act ive- length *cached-amem*) ' : type 'art-q))) 
(copy-array-contents *cachcd-amenr* copy) 
copy)) : just return a copy 

;nakes sure that the correct program in loaded in the F£P and then starts it. 
(defun assure-fep-progr am- loaded (symbol) 

(let ((module (get symbol * rSSk-object-code) ) ) 

(if (null module) (terror nil "^The symbol --A has no compiled code," symbol)) 
(if (neq Module «fep-program- loaded*) 

(setq *fep-program-start-address* (asmGSk: fep- load-module module t))) 
(setq *fep-program- loaded* module) 
(fep-jump *fcp-program-start-address*))) 
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:;; -«- Mode: LIL; Package: LIL; Base: 8 -«- 

(include "Types-and-macros") 

Cmclude "fsm.EXT" "fep-uti le.EXT" "machine, EXT") 

(deftype memory-type (enuMeration vnea amem bmem cmem type-tnap diffptay-aem gc-«ap} ) 
(deftype location-type (structure 

(value long) 

(■en-type ■etnory-type} ) ) 

(def macro locat ion-and-mem-type (value nem-type) 
'(let (((It location-type))) 

(set-fieids It value , value sem-type , mem- type) 
It)) 

(defatommacro «point-stack-8tze» 8) 

(defvar sonebody-a I ready-debugging? boofe false) 

(def var «input-buffer« (array byte 40.) ()) 

Cdefvar »input-buffer-po inter* word 8) 

(defvar «input-buffer-! imit* uord 0) 

(defvar «rubout-tn-progres5* boole false) 

(defvar *defaul t-memory* memory-type vmem) 

(defvar »point« location-type ()) 

(defvar «potnt-open?* boote false) 

(defvar «point-8tack« (array location-type «pomt-stack-st2e«) 0) 

(defvar «potnt-8tack-pointer» uord 9) 

(defvar «tab-point* location-type ()) 

(defvar »tab-point-val )d« boole false) 

(defvar »symbot ic-typeout-mode* boole true) 

(defvar »debug-long« long 8) 

(defvar «debug-tbus-uord« Ibus-uord {)) 

(defvar «debug-mtcro instruct ion* microinstruction ()) 

(defun ini t-debugger 

(setq somebody-already-debugging? false) 

(setq *input-buf fer-pointer* 0) 

(setq *input-buf fer-l tmt t* 0) 

(setq *rubout-in-progress* false) 

(setq *defau) t-memory* vmem) 

(setq «point* ( locat ion-and-mem-type 8 vmem)) 

(setq *point-open?» false) 

(loop for (i word) upfrom below *point-stack-8i2e« 

do (setf (aref mpoint- stack* t) «point»n 
(setq «point-8tack-po inter* 0) 
(setq «tab-point* *point*) 
(setq *tab-point-vaI id* false) 
(setq «symbol ic-typeout-mode* true) 
) 

(defun debug ((stream streamiV 
(if somcbody-already-debuggfng? 

(format stream '''^^Sorry, somebody already using debugger.**) 
(Iet*-globai ty ((somebody-already-debugging? true)) 

(wi th-var-bound (make-pointer stream-ptr standard-input) 
(wi th-var-bound (make-pointer stream-ptr standard-output) 
(setq standard- input stream 
standard-output stream) 
(format t ""-^^ntering debugger***) 
(debug-top- level) 
(format t "--^Exiting debugger.**)))))) 

(defun (debug-tyi byte) 
(let (((char byte))) 

(cond (*rubout-in-progress« -1) 

((# *input-buf fer-pointer* *input-buf fer-t imi t*) 
(progl (aref *input-buf fer* *input-buf fer-pointer») 
(incf »input-buffer-pointer*))) 
((merrber (setq char (tyi)) ' (#\rubout /!^ol77)) ;li8pm or asci i 
(deoug-start-rubout) ) 
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{T (incf »rnput-buf fer-t iwi t«) 

(incf «input-buffer-pointer«) 

(self (aref *input-buf fer» «input-buf fer-pointer») char) 

(tyo char) 

char)))) 

(defun (debug-start-rubout byte) 
(setq *rubout-in-pPogre5a* true) 
(setq «input-buf fer-pointer« 81 
(unless (zercp «input-buf fer-I i»i t*) (tyo U/\)) 
(loop with (char byte) 

unless (zerop «input-buf fer-I im! t«) 
do (tyo (aref «input-buf fer* *input-buf fcr-I imi t») ) 
(uhen (zerop (decf *input-buf fer- 1 imi t»)) 
(tyo n/\)) 

do (setq char (tyi)) 

while (member char ' (#\pubout #ol77) ) 

finally (unless (zerop «i nput-buffer-1 i»i t») (tyo tf/\)) 

(sctf (aref «input-buf fer* «tnput-buffcr-i iiitt*} char) 

(incf «input-buf fer-I imi t«) 

(tyo char) 

(return char))) 

(defvar «selected-memory« memory-type vmen) 

(defvsr «scratch-value-l* long 8) 

(defvar «scratch-value-2* long 8) 

(defvar »scratch-va!ue-l-val id» boole false) 

(defvar «scr3tch-value-2-vat id* boole false) 

(defvar «ar i th-operator* byte U/+) 

(defun defcug-reset-state 

(setq «rubout-in-progress« false) 

(setq «se!ected-memory« «defaul t-memory*) 

(setq *scratch-value-l« 8) 

(setq *scratch-vaiue-2* 8) 

(setq «scratch-value-l-vai id* false) 

(setq *scratch-value-2-val id* false) 

(setq *art th-operator* U/-*-) 

) 

(defun debug-f inish-ar i thmetic 
(cond ((not *scratch-value-l-val id*) 

(setq *scratch-value-l* «scratch-value-2* 

*scratch-value-l-vai id* *scratch-value-2-vat id*)) 
(*scratch-vaIue-2-val id* 
(setq «scratch-value-l* 

(select *ar( th-operator* 

(#/- (- «scratch-vatue-l* «scratch-yaIue-2«)) 
(^/+ (+ «scratch-value-l« «scratch-value-2«)) 
itf/m (* (word «3cratch-value-l«) (word «scratch-value-2*) ) ) ) ) )) 
(setq *scratch-value-2« 8) 
(setq *scratch-value-2-val id* false)) 

(defun debug-top-level I) 

(loop as (f irst-t tme-through boole) first true then false 

as (char byte) - (debug-tyl) 

if (or «rubout-in-progre58* first-time-through) 

do (debug-reset -state) 

if (- char /!?o32) 

do (return) 

do (debug-process-char char))) 

(defun debug-process-char ((char byte)) ;8o others can force input 
(cond iis U/B char tf/3) (debug-process-digi t char)) 

{(member char * («/ ! ff// U/[)) (debug-open-new- location char)) 
((member char * (#\return ^ol5 «r\lf jyol2 tf/^ #ol8) ) 

(debug-close-current- location-maybe-open-new char)) 
((member char ' [U\tat tfolD) 

(debug- indirect -through-cur rent-value)) 
((• char ^Xaltmode) (debug-process-al tmode) ) 
({- char tf/m) (debug-set-memory-type)) 
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((eewber char M#/+ «f\8pace U/~ tf/*)) (debug-setup-for-ar i thmet ic char)) 
(T (format t • ??? ") 
(debug-rcsct-ttate) ) ) ) 

(defun debug-setup-for-ar i thnetic ((char byte)) 
(debug-f intsh-ari thoetic) 

(when {- char <?\sp3ce) (setq char #/+) ) ;canon>cai ize 
(aetq »ari th-operator* char)) 

(defun debug-pPoce«9-digt t ((char byte)) 

(setq »5cratch-value-2« (+ ilshl *scratch-vatue-2» 3) char (- U/Q))) 
(sctq «»cpatch-value-2-va! id* true)) 

(defun debug-open-new- location ((char byte)) 
(debug-f inish-ari thne tic) 
(if (not «5cratch-value-l-val id«) 
(fopwat t " Location? ") 
(debug-push-point) 

(setq «point« ( locat ion-and-»em-type «8cratch-vatue-l* «seiected-inemory*) ) 
(setq *point-opcn?« true) 

(if (- char U/ i) (setq »symbol tc-typeout-«ode« false)) 
(if (- char #/!) 

(forwat t " ") 
(debug-read-po i n t ) 
(debug-pr i nt-curren t-va I ue) ) ) ) 

(defun debug-ctose-current-location-«aybe-open-new ((char byte)) 
(debug-f i n i sh-ap i thme t i c) 
(when »scpatch-value-l-val id* 

(debug-depos i t-va I ue- to-po t nt ) ) 
(fopaat t "«^'*) ; Indication of closing 

(if (weBbep chap ' (#\peturn <fol5)) 

(tetq «8y«boi ic-typeout-mode* tpue) 

(tncf (value *point*) (tf (nembep char *(tf\lf ^VolZ) ) 1 -D) 

(debug-read-point) 

(debug-pp i nt-currcnt-va I ue) ) ) 

(defun debug-ppocess-al tnode 
(let ((chap (debug-tyi))) 
(unless *pubout-in-ppogpes5* 

(cond ((nembep char ' (JSrXreturn ^^olS «r\lf #ol2 tf/^ «fol8)) 

(debug-push-point) ;8ave it at end of ring 

(debug-pop-point) ;get it back 

(debug-pop-point) ;now get previous point 

(incf (value.*point*) (cond ( (aember char ' (tfXretupn #ol5) ) 8) 

((■lembep chap ' (ffWf <fol2)) 1) 
((member chap M0/^#ol8)) -1))) 
(debug-pead-po i nt) 
(debug-pr i nt-current-va I ue) ) 
)))) 

(defun debug-sct-mertiory-type 
(let ((char (debug-tyi))) 

(unless «pubout-in-progpess« 

(if (s #/a char U/k\ (setq char (- chap U/a (- ff/^)))) 
(select chap 

«f/A (setq «se!ccted-niemopy* amem)) 
ift/B (setq «&elected-meinopy» bmetn)) 
itf/C (setq vselected-memopy* cmem)) 
(jy/D (setq *selected-mefliopy* display-mem)) 
(jy/V (setq *8etected-meffl0py* vmem) ) 
Of /I (setq *setected-meffiOpy* type-map)) 
(otherwise (format t "?? Unknown memory type,") 
(debug-reset-state) ) ) ) ) ) 

(defun debug-push-point () 

(setq *point-stack-pointer» (logand (1+ *point-8tack-pointer«) 7)) ;pdp-18 style 
(setq (aref *point-8tack* *point-stack-pointep*) «point*)) 

(defun debug-pop-point 

(setq «point« (apef *point-stack« «point-stack-pointcp*) ) ;still pdp-18 style 
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;;; -«- Hode: LIL; Package: LIL; Base: 8; Lowercaserof-ccurse -«- 

(include "Types-and-Biacros" ) 

(include "str ing.EXT" "chaos-ncp.EXT" "chaos-user. EXT" "chaos-servers. EXT") 

(include "di sk-raw. EXT" "disk, EXT" " f oad-wor f d.EXT") 

(include "fep-ut i Is.EXT") 

(defpsect code address 41C033) 

(defpsect data address 763809) 

(defpsect fep-io address <fo7760O320 address-only t) 

(defpsect absolute address address-only t) 

(externals (fsm-init long long) 

(ini t-processes) (ini t-network) (ini t-di splay) 

(f ep-net-reset) ( ini t-hsb-f or-dcp) 

(ini t-state-saving) ;in Machine 

( ini t-keyboard) ; in Keyboard 

(conf ig-ethernet) 

(ini t-chaos-ncp) (add-chaos-servcr string long) 

; (ini t-disk) 

(scheduler) 

(ICbd-process-top- level ) 

(Icons- i nter face-top- 1 eve i ) 

) 

(defun MAIN 

(declare (require asm-hack)) 
-- (fsm-init /yo710G3e ;;^oi000O00) 
(ini t-keyboard) 
(ini t-state-saving) 
(ini t-processes) 
( ini t-netuork) 
(ini t-hsb-for-dcp) 
(ini t-di splay) 
; (fep-net-reset) 
(ccnf ig-ethernet) 
(ini t-chaos-ncp) 

(add-chaos-server "STATUS" #' status-server) 
(add-chaos-server "UPTIME" ;Sf*upt ime-server) 

(add-chaos-server "DUnP -ROUTING-TABLE" <^' dump-rout ing-tab I e-server) 
(add-chaos-server "ECHO" #* echo-server) 
(add-chaos-server "SUPDUP" #' forwarding-supdup-server) 

(setq netuork-stream NULL-stream) 
(add-chaos-server "TAL<" #* talk-server) 

(ini t-disk) 

(ini t-load-wor Id) 

(setq «netuork-requested-cra8h« false) 
(add-chaos-server "CRASH" ;t^' crash-server) 
(proccss-run-function "Remote disk" jyVemote-dt sk) 

(process-run-function "keyboard" ^f'Kbd-process-top-tevet ) 
(process-run-function "Lcons interface" ^'Lcons- inter face- top- (eve I ) 

: (process-run-funct ion "Blip" ^'blip) 
; (format t "-•XCailing scheduler."? 
(scheduler) 
) 

#1 UEM's main 

(defun MAIN 

(declare (require asm-hack)) 

(fsn-.-init #0710000 ffolBZZdZZ) 

(ini t-keyboard) ;init8 DMA as uell 

(ini t-state-saving) 

( ini t-processes) 

(ini t-netuiork) 

(ini t-hsb-for-dcp) 
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(ini t-di sptay) 
(fep-net-reset) 
(conf ig-ethernet) 
( irvi t-chaos-ncp) 

(add-chaos-server "STATUS" ^•status-server) 
(add-chaos-server "UPTIHE" <?* uptime-server) 

(add-chacs-ser vcr "DLHIP-ROUTING-TABLE" JSf' dump-rout ing- table-server) 
(3dd-chaos-scrvcr "ECHO" *^* echo-server) 
(adci-chcos-servcr **SUPDUP" ;?' forward ing-supdup-server) 

(setq network-stream NULL-stream) 
ladd-chaos-server "TALK" #' talk-server) 

(init-disk) 

(ini t-Ioad-wor Id) 

(setq *network-requested-crash« false) 
(add-choos-server "CRASH" #* crash-server) 
(process-run-function "Remote disk" <?*remote-di sk) 

(prccess-run-function "Keyboard" <f'Kbd-process-top-leve! ) 
(process-run-function "Icons interface" ;!?'Lcons-interface-top-lcvel ) 

; (process-run-function "Blip" /S^'blip) 
; (format t "-^Calling scheduler.") 
(scheduler) 
) \ff 



(defun blip (loop do (process-sleep £308. ) (tyo #/,))) 

(defvar «network-requested-crash* boole false) 

(defun crash-server 

(setq «network-requeGted-crash* true) 

(funcali (coerce long (make-pointer word-ptr (word 47103))))) 

(defvar network-stream stream NULL-stream) 

(defun talk-server ;not allowed to process-watt 

(process-run-function "Talker safety" ii(* talK-server-1) ) 

(defun talk-server-1 ;al lowed to process-wait 

(let ((conn (listen "TALK" 3 true))) 
(cond ( (nul I conn) ) 

((not (null (conn-error-message conn))) 

(remove-conn conn) ) 
(T (accept conn) 

(let ((old-stream network-stream) 

(new-stream (chaos-make-stream conn))) 
(unless (null new-stream) 

(setf (character-set (coerce chaos-stream new-stream) ) cscs-telnet) 
(setq network-stream new-stream) 
(unless (null old-stream) 

(stream-close old-stream)))))))) 

(defun (tyi-lockout byte) 
(when (nul I network-stream) 

(process-wait "Uait for Network stream" <f'wai t-for-network-stream) ) 
(unless (kbd-tyi -no-hang network-stream) 

(process-wait "Tyi" #*8tream-kbd-tyi -no-hang network-stream)) 
(tyi network-stream) ) 

(defun (wai t-for-network-stream boole) 
(not (null network-stream))) 
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(defvn (read-number word) 
Hoop with (ans word) • " 

as (char byte) « (tyi-iocko«jt) 
- do (tyo char network-stream) 

if (or (< char U/Z) t> chsr »/3J) 

return ans 

do (setq ans (+ (* ans 8) (- char U/d))))) 



944 



(defvar *refT!ote-di sk-host« word Z) 
(defvor *pcmote-disk-conn* conn NULL-conn) 
(deftupe access-path (enumeration ap-net ap-disK)) 
(defvar access-path access-path ap-net) 

(defun remote-disk 

(setq *pemote-di sk-host* 0) 

(setq «remote-disk-conn* NULL-conn) 

(setq access-path ap-disk) 

(loop do (select (tyi-lockout) 

(#/h (do-h)) 

iU/r (do-p)) 

(#/o (do-ol) 

(#/d {60'<i)) 

itf/n (do-n)) 

(#/? (do-?)) 

(#/w (do-w)) 

itt/n (do-m)) 

iU/c (do-c)) 

(#/i (do-D) 

(ff/Q (funcall (coerce long (make-pointer word-ptr (wopd 47100) ))) ) 

(otherwise (fopmat netwopk-strearo "??? ")))) 
} 



(defun do-c 

(loop repeat (progn (format network-stream "-dumber of characters: ") 

(read-number)) 
do (tyo tt/a network-stream))) 

(externa) fep-ciear-hsb-di sk-error ()) 
(defun do-d 

(setq access-path ap-disk) 

(fep-ciear-hsb-di sk-error) 

(forniat network-stream "^lUsing the real disk.-^t")) 
(defun do-n 

(setq access-path ap-netJ 

(format network-stream "-wtSimulating disk over the net.^X")) 

(defun do-h 

(format network-stpeam "Host: *') 
(set-pemote-host (pead-numbep) ) ) 

(deftype typeout-mode (enumeration tm-octal tm-asci i tm-3Gb]t)) 



(defword 


lmach-3( 


]bit (: 


comma) 




(:byte 


"Uord 


: " 32. 


U.{m 3B. 


0.)) 


(:byte 


"Uord 1 


' " 32, 


Xf. {* 3B. 


1.)) 


(:byte 


"Uord 2 


' " 32. 


n. (« 3B. 


2.)) 


(:fcyte 


"Ucrd 3 


" 32. 


n. (* 3S. 


3.)) 


(:byte 


"Uord 4 


" 32. 


n, (* 36. 


4.)) 


(:byte 


"Uord 5 


" 32. 


n, (* 35. 


5.)) 


(:byte 


"Uord 6 


" 32, 


U, (« 3B. 


S.)) 


(:byte 
) 


"Uord 7 


- 32. 


n, (* 36. 


7.)) 



(defun do-r 

(format network-stream "Read block number: ") 
(let ((dp (at locate-disk-page-preload (read-number) 0))) 
(5ii ssue-di sk-page-read dp) 
(format network-stream "-^XData received.") 
(locp with (point word) - 

with (inc-dec word) - 1 
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uith (typeout-mode typeout-node) • tm-octal 

as (print-something-this-t irae boole) » true 
do (select (tyi-lockout) 

iU/U (incf point inc-dec)) 

iff/P (tyo tt/^ network-stream) (decf point inc-dec)) 

{#/. (setq inc-dec (read-number) 

pr intrsomething-thi B-time false)) 
(#/•* (setq typeout-mode t«-ascii)) 
it//X (setq typeout-mode tm-3Sbit}) 
((;y\return tfolS) (setq typeout-mode tm-octal)) 
{M/q (return)) 

(otherwise (format networK-stream "??? "))) 
if print-something-thi«-t ime 
do (setq inc-dec 1) 

(format network-stream "^-A^// " point) 
(select typieout-ffiode 

(tm-octal (format network-stream "^ " 

(<-slong (aref (disk-data-slongs (disk-data dp)) point)))) 
(tm-ascii (format network-stream "--B " 

(make-pointer byte-ptr (aref (disk-data-bytes (di sk-data dp) ) 

(» point 4))) 
4)) 
(tm-SGbtt {format network-stream "44 * 

(coerce «byte-array-ptr 

(make-pointer long-ptr 

(aref (disk-data- longs (disk-data dp)) point))) 
lmach-3Gbit) 
(setq inc-dec 3) ) 
) 
) 
(format network-stream "-v^eturning disk page") 
(rcturn-disk-page dp))) 

(defun (prompt-open-f i te file-stream) ((prompt string)) 
(format network-stream "^'A" prompt) 
(let» ((filename (readline)) 

(fs (open-file filename dm-btock dd-read))) 
(return-str i ng f i I ename) 
fs)) 

(defun do-o 

(let ((fs (prompt-open-file "File to open: "))) 

(cond ((null fs) (format network-stream "-.tNul I file stream")) 
((not (null (error-message fs))) 

(format network-stream "-rXError in file stream: *rA" (error-message fs))) 
(T (format network-stream "-ZPerhaps file is open.") 
(format network-stream "^-XPage info:") 
(loop for (base long) - 8 then (-«- base count) 

as (die dpn-and-count) « (d4c-for-btock fs base) 
as (dpn long) • (dpn die) 
unti I (■ dpn -1) 
as (count long) • (count dfic) 

do (format network-stream "-'X [*^,-^)" dpn (+ dpn count)) 
})) 
(close-file-stream fs) 

(format network-stream "*«XFi!e stream closed.") 
)) 

(defun (readline string) 
(let ((s (make-string 180))) 

(loop for (ch byte) • (tyi-lockout) 
for (i word) upfrom 8 
do (tyo ch network-stream) 
until (member ch ' itf\cr tfWf ;Sfol5 tfol2)) 
do (setf (aref (string-bytes s) i) ch) 
finally (setf (string-length s) i)) 
s)) 

(defun (set-rcmote-host boole) ((host word)) 
(If (not (null *remote-di sk-conn*) ) 
(remove-conn *remote-di sk-conn«) ) 
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(setq *pemote-di5K-ho9t* S 

»renote-disk-conn* tJULL-conn) 
(let ((conn (connect NULL-atring host "DCP-REnOTE-DISK" 2 6033.))) 
(cond ((null conn) false) 

((not (nui! (conn-error-message conn))) 
(format network-stream *'A-lConnect error: -A" (conn-error-nessage conn)) 
(remove-conn conn) 
false) 

(T (setq «remote-di sk-host» host) 
(setq «remote-di sk-conn* conn) 

(format network-stream "^XOCP-REH0TE-DIS< connection is open.") 
true)))) 

(defwcrd disk-status (rCOnriA) 

(:BIT (READY) ''Ready*' "Not ready") 

(:BIT (ON-CYLINOER) 1 "On cylinder" "Off cyh'nder") 

(:BIT (SEEK-ERRORl 2 "Seek error") 

(:BIT (FAULT) 3 "Fault") 

(:BIT (READ-ONLY) 4 "Read-only") 

(:BIT (ADDRESS-HARK ) 5 "Address-mark") 

(:BIT INDEX G) 

(:BIT SECTOR 7J 

(:BIT READ-CL< 18) 

(:BIT SERVO-CLK 11) 

(:BIT READ-DATA 12) 

(:BIT (PADDLE-DISABLE) 13 "Paddle disable" "Paddle enable") 

(:BIT (DISK-ERROR) 14 "Disk error") 

(:BIT (SELECT-ERROR) 15 "Select error") 

{:BIT (OVERRUN) 16 "Overrun") 

{:BIT (ECC«ZERO) 17 "ECC-B" "ECC-0") 

(:BIT READ-COnPARE 22) 

(:aiT END-FLAG 21) 

(:BIT BUF-BUSY 22) 

(:BIT UAKEUP 23) 

(:BIT URITE-DATA 24) 

(:BIT (NOT-SET-DONE NIL 8) 25 NIL "Set done") 

(:BYTE (U-FUNC) 2 26 NIL "Stop if ECC.8" "Err if start block" "Func set done") 

(:BIT (NOT-IDLE) 38 "STH not idle" "STH Idle") 

(:BIT NEXT-STATE-8 31) 

(:BIT (ADVANCE-STATE) 32 "Advance state") 

(:BYT£ U-STATE 5 33)) 

(defword net-status (:COnnA) 
(:BYTE -Task:" 4 8) 

{:BIT (CPU-RCV-ENABLE) 4 "CPU receive enable" "CPU transmit enable") 
(:BYTE "Input byte count:" 2 5) 

(:BIT (BACKOFF-ENABLED) 7 "Backoff enabled") 

(:BIT (BUFFER-OVERFLOU) 18 "Buffer overflow") 

(:BIT (NET-COLLISION) 11 "Net collision") 

(:BIT (PREAHBLE-ERROR) 12 "Preamble error") 

(tBIT (ALIGNHENT-ERROR) 13 "Alignment error") 

(:BIT (CRC -ERROR) 14 "CRC error") 

(:BIT (PKT-RECEIVED) 15 "Packet received") 

(:BIT (CABLE-BUSY) 16 "Cable busy") 

(:BIT (XHT-REQUEST) 17 "Transmit request") 

(:BIT (RECEIVE-CLK) 28 "Receive clock") 

(:BIT (RECEIVE-DATA) 21 "Receive data") 

(:BIT (DATA-VALID) 22 "Data valid") 

(:BIT (COLLISION-DETECT) 23 "Collision detect") 

(:BIT (TEST-CABLE-BUSY) 24 "Cable busy(test)") 

(:BIT (TRANSP1IT-CLK) 25 NIL "Transmit clock") 

(:B1T (TRANSniT-DATA) 26 "Transmit data") 

(:BIT (CRC-DATA) 27 "CRC data") 

(:BIT (NET-START) 38 NIL "Net start") 

(:BIT (UAIT-FOR-PKT) 31 NIL "Wait for packet") 

(:Bn {PREAnBLE-2i 32 NIL ^Preambie 8") 

(:BIT (PREAHBLE-IJ 33 NIL '^Preamble 1") 
<:BYTE "Transmit state:" 2 34) 

(:BIT (PKT-BEING-TRANSniTTEO) 36 NIL "Packet being transmitted") 

(:BIT (PREAHBLE-DATA) 37 "Preamble data")) 
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(defwopd 


32bit-word (: comma) 


(:byte 


"Value:" 32. 8) 


(:tiyte 


"Byte 8:- 8 88.) 


(:t3yte 


"Byte 1:" 8 BB.) 


{:byte 


"Byte 2:" 8 IB.) 


(:Ciyte 
) 


"Byte 3:" 8 24.) 
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{defuord 3Sbit-uord (:comma) 
{:byte "Tag: " 4. SS. ) 



<;byte 


"Value: 


" 32. 8) 


(:byte 


"Byte 8 


:" 8 88.) 


(:byte 


"Byte 1 


" 8 88.) 


(:byte 


"Byte 2 


" S 26,) 


(:byte 
) 


"Byte 3 


" 8 24.) 



(dGftype 4byte5 (array byte 4)) 
(defun do-? i) 

(loop uith (finished boole) « faise 
with (value long) 
uith (defwoPd uord-descr ipt ion) 
with (4bytes 4bytes) 
as (valid boole) • true 
do (fornat network-stream "-^&Regi stcr: ") 
(select (tyi-lockout) 

iU/6 (setq value (rcad-iob-reg *disk-8tatus-of feet*) 

defword disk-etatus) ) 
(#/n (setq value (read-iob-reg «net-status-of feet*) 

defword net-status)) 
(#/o (setq value (read-iob-reg (progn (format netwopk-strean "Offset: ") 

(pead-numbep) ) ) 
defwopd 32bit-woPd)) 
(M/q (setq finished tpue)) 
(otherwise (setq valid false))) 
unt i I finished 
when val id 
do (loop fop (i wopd) upfpom 8 below 4 

do (setf (apef 4bytes i) (byte value)) 
(setq value ( t shp value 8))) 
(fopmat netwopk-stpeam "^^^4" 

(coepce *byte-appay-ptr (make-pointep byte-ptp (apef 4bytes 8))) 
defwopd))) 

(defun do-w ;papse micpocode file 

(let ((fs (ppompt-open-f 1 le "flicpocode file to papse: "))) 

(cond ((null fs) (format network-stpeam "--XNul 1 file stpcam.")) 
((not (null (eppop-message fs))) 

(fopmat netwoPk-stpeam "*X£prop in file stpsam: *-A" (cppor-sjessage fs))) 
(T (fopwat netwopk-stpeam "-^XFile should be open,") 
(set-f i lepos-and-mode fs 8 dm-wopd) 

(loop initially (fopmat netwopk-stpeam "-^^ame stping: ") 
for (n wopd) downfpom (disk-tyi-lG fs) by 2 above 8 
as (w wopd) « (disk-tyi-lS fs) 
do (tyo (byte u) netwoPk-stpeam) 

if (i« n 1) do (tyo (byte (potr w 8)) netwopk-stPcam) ) 
(fop«at network-stpeam "*4Vepsion number: ^** (disk-tyi-lS fs)) 
(loop as (continue byte) • (ppogn (format netwopk-stpcara " Next block? ") 

(tgi-lockout)) 
while (membep continue * (tfXspace #/y #/Y) ) 
do (show-micpocode-load-block fs) ) 
(close-f i le-stpeam fs) 
(fopmat network-stPeam "*^i le stpeam closed."))))) 

(defun show-micpocode- load-block ((fs f i le-stp«a») ) 
(let* ((which (disk-tyt-lB fs)) 
(stapt (disk-tyi-iS fs)) 
(n (disk-tyi-lG f s) ) 
(size (disk-tyi-16 fs)) 
(nsize (if (bit-test which UolZQ) (+ sire 4) size))) 
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(format network-stream "^^^A. -vQ words (size -^) starting at -^0. Go ahead? " 
(select which 
(1 "Type map") 
(2 "A memory") 
(3 "B memory") 
(4 "C memory") 
(104 "C memory patches") 

(otherwise "Unknown microcode memory index.")) 
n size start) 
(loop while (member (tyi -lockout) * {ff\space ff/y ti/y)) 
do (loop repeat 29 

whj le (> n 0) 

do (loop initially (format network-stream ".^4^// ■ start) 
repeat size 

do (format network-stream "*0 " (disk-tyi-lG fs))) 
when im size nsrze) 
do (loop initially (format network-stream 

" Function: *0, Bytes: " 
Cdisk-tyi-lG fs)) 
repeat (- nsize size 1) 
as (next word) - (diek-tyi-lB fa) 
do (tyo (byte next) network-stream) 

(tyo (byte (Ishr next 8)) network-stream)) 
do 

(decf n) 
(incf start)) 
whi le (> n 0> 

do (format network-stream "-^— More?— ") 
) 
(loop repeat (« n nsize) do (disk-tyi-16 fs)) :read what user didn't 

(defun do-w ;parse world load file 

(let ((fs (prompt-open-file "World file to parses "))) 

(cond ((null fs) (format network-stream "*.XNuM file stream. ")) 
((not (null (error-message fs))) 

(format network-stream "-^tError in file stream: *A" (error-message fs))) 
(T (format network-stream "-vXFile should be open.") 
(set-f i lepos-and-mode fs dm-3Gbit) 
(format network-stream "•^IC major version: ^, Uorld-load version: *0" 

(disk-tyi-3S-data fs) (disk-tyi-36-data fs)) 
(let* ((nsparse (word (di sk-tyi-3G-data fs))) 
(ninitial (word (di sk-tyi-3S-data fs))) 
(nioad (word (di sk-tyt-3G-data fs)))) 

(format network-stream 

"^A-^ sparse entries, *^ initial map entries, ^ load map entries, 
nsparse ninitial nIoad) 
(maybe-show-sparse nsparse^ fa) 
(maybe-show-ini t laf ninitial fs) 
(maybe-show-load nIoad fs)) 
(close-file-stream fs) 
(format network-stream "-^r^ile stream closed."))))) 

(defun maybe-show-sparse ( (n word) (fs file-stream)) 

(format network-stream "^Show some of the -^0 sparse entries? " n) 
(loop with (entry-num long) • 

while (member (tyi- lockout) * (JSfXspace #/y #/Y) ) 
do ( loop repeat 20 

whi le (> n 0) 

as (VnA long) - (di sk-tyi-2B-data fs) 
as (Ibw tbus-word) « (disk-tyi-36 fs) 

do (format network-stream "^AEntry ^: VHA -^, HighA: ^, Data -vQ" 
entry-num vma (ecc+high Ibw) (data Ibw)) 
(decf n) 

(incf entry-num)) 
whi le (> n 0) 

do (format network-stream "^ — (lore? — ") 
) 
(loop repeat (« n 2) do (di sk-tyi-3B-data fs)) 
) 
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(defun maybe-shou-ini t ia! ( (n uord) (fs file-stream)) 
(maybe-show-int t iai-or-load n fs "initial map")) 

fdefurv maybe-shou-lcad ( (n word) (fs file-stream)) 
{maybv-show-ini t iai-or-!oad n fs "load map")) 

(defun naybe-shou-initial-op-load ((nuord) (f s f i le-stream) (which string)) 
(forrrat network-stream "-^Shou some of the *nO <^A entries? " n which) 
(loop with (entry-num long) « 

while (member (tyi-lockout) ' (#\space #/y #/Y)) 
do ( loop repeat 28 

whi le (> n 8) 

as (VriA long) « (disk-tyi-3B-data fs) 

as (nwords long) « (dt sk-tyi-SS-data fs) 

as (file-page-number long) ■ (di8k-tyi-3S-data fs) 

do (format network-stream 

"-^^ntry -vQ: Starting VtlA ^, --0 words, starting disk page ^^ 
entry-num vma nwords f i le-page-numbcr) 
(decf n) 

(incf entry-nuffl) ) 
whi le (> n 0) 

do (format network-stream "-** — More? — ") 
) 
(loop repeat (* n 3) do (di sk-ty)-3B-data fs)) 
) 

(defun (y-or-n-p boote) ((prompt string)) 

(loop do (format network-stream "-^A (Y or N) " prompt) 
as (char byte) « t tyi-lockout) 
if (member char M«lt/y Uf\ #\space)) 
return (progn (format network-stream "Yes. *> true) 
if (member char ' (#/n tf/N Mol77}} 
return (progn (format network-stream *No, ") false) 
)) 

(defun do- I 

(let* ((filename (progn (format network-stream "'v&Uorld load file: ") 

(read I tne))) 
(message (load-world 8 filename 

false ; insta-boot 

false :maps after initial 

false ;use microcode 

})) 
(format network-stream "^^^eturn answer was '^S.** message) 
(return-string message) 
(return-string filename))) 

(defun Xissue-disk-page-read ((dp dtsk^page^) 
(select access-path 

(ap-net (ti ssue-disk-page-read-via-net dp) 3 
(ap-disk (Xissue-disk-page-read-via-disk dp)))) 

(defun tissue-disk-page-read-via-net (idp disk-page)) 

(format network-strcan» ***X(>ti ssue-di sk-page-read ,.. -^ , • . ) " (dpn dp)) 
(let* ((unit (disk-unit dp)) 
(dpn (dpn dp) ) 

(pointer (coerce long (disk-data dp)))) 
(if (not (null (read-pkts «remote-disk-conn*) ) ) 

(format network-stream '^XUnexpected data in connection, using it!!!")) 
(let* ((pkt (allocate-pkt))) 

(set-pkt-string pkt "(READ 88888883888)") 
(loop repeat 11, 

for (i long) • dpn then (Ishr i 3) 

for (j word) • (- (pkt-nbytes pkt) 2) then (1- j) 

do (setf (aref (pkt-data-bytes pkt) j) 

(byte (+ n/2 (logand (byte i) 7))))) 
(send-pkt «remote-di sk-conn» pkt dat-op)) 
(locp with (count word) - (* 2S8. 4) 

with (ptr byte-ptr) - (coerce byte-ptr pointer) 
unti I (zerop count) 
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38 (pkt pkt) - (get-next-pkt «remote-disk-conn« false) 
if (or (null pkt) (not (null (pkt-error pkt) ) ) ) 
do (format network-stream "^XConnect ion error in tread: -^A" 
(if (null pkt) "???•' (pkt-error pkt))) 
(if (not (null pkt)) (return-pkt pkt)) 
(return) 
do (loop repeat (win count (pkt-nbytes pkt)) 
for (i uord) upfrom 8 
unt i I (zerop count) 

do (setf •ptr (aref (pkt-data-byte3 pkt) i)) 
(decf count) 

(ptr-incf ptr byte-ptr (tgpe-slze byte))) 
(return-pkt pkt)))) 

(defun Xi ssue-di sk-page-read-vta-disk {(dp disk-page)) 

(process-wait **D'isk wait my turn" #* tidprvd-uai t) 

(setq fep-hsb-disk-page dp) 

(process-wait "Disk wait for completion" #'Xidprvd-wai t) ) 
(defun (Sidprvd-wai t boole) 

(nui t fep-hsb-disk-page)) 

(defvar fep-hsb-disk-page disk-page NULL -disk -page) 

(defun tissue-disk-page-write ((unit word) (dpn long) (pointer long)) 
(format network-stream "-%tAttempt to do a disk write.")) 

;;;-«^node: Lil: Package:Lil; Base:8. -«- 
;;; (c) Copyright 1982, Symbolics, Inc. 

(INCLUDE "Types-and-macros" "Fep-ut i Is.ext") 

(EXTERNAL INI T-DI SPLAY ()) 

; Special bits in SPY-OPC 

(DEFATOnriACRO OPC-NOT-NOP * 40888) 
(DEFATOnriACRO DPC-TAStC-SUITCH '188888) 

; Special bits in SPY-NEXT-CPC 

{DEFAT(3mACR0 SPY-NEXT-CPC-RAU-BIT-12 '48888) ; before skip logic 
ll2ZQQd not wired to anything yet 

;This variable holds the desired contents of the control register 
; while the machine is running. Use it to turn on and off features 
;such as error halts, tasking, and traps. 
(DEFVAR *SQ-CTL-UHILE.RUNNING« SQ-CTL 

(BUILD SQ-CTL ENABLE-DP 1 ENABLE-SQ 1 ENABLE-CTEn 1 ENABLE-TRAP 1 
ENABLE-ERRHALT 1 ENABLE -UP D) 

;Thi8 is a record of the last value written into SQ-CTL. 
(DEFVAR «CURRENT-SQ-CTL« SQ-CTL (BUILD SQ-CTL) ) 

(DEfSn'SeSe{S88^^^ '"'"'' '** Dgnamic rams suffer .. So don't call friviously. 

(URITE-SQ-CTL-TO-STOP-nACHINE) 
(DISCARD-STATE) 

; (SETUP-nACHINE-DEPENDENCIES) 
(LET-GLOBALLY ( («SAVE-STATE« FALSE)) 

;; Howard... Uhat does this do? /UEH 

(SETQ FEP-HSB-CONTROL (BUILD FEP-HSB-CONTROL URITE-TO-DEV "Urlte" 

COUNT-UP "Up" NOT-SPY-DHA-BUSY 8)) 

(SETQ FEP-HSB-POINTER -1) 

(SETQ FEP-HSB-DATA 8) .Clear busy 

;; Clear special Lbus modes. 

(SETQ FEP-LBUS-CONTROL (BUILD FEP-LBUS-CONTROL USE-UNC-DATA "Use Uncorrected Data" 

IGN-DOUBLE-ECC "Ignore Double ECC Error" 

NOT-BUSY "Lbus buffer busy")) 
(SETQ FEP-BDARD-ID-CONTRDL (BUILD FEP-BOARD- ID-CONTROL CONTINUITY "Continuity")) 
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;; Set I bus power reset, <peset-!bus) will clear it 
(SETQ FEP-PROC-CONTROL (BUILD FEP-PROC -CONTROL 

POUER-RESET "Lbus Power Reset" LBUS-RESET "Lbus Reset")) 
(RESET-LBUS) ;clear power reset. 

(RESET-TASiCS) 

(nC-RESET)) 
(INIT-DISFLAY) 
) 

(DEFUN RESET-LBUS 

(SETQ FEP-PROC-CONTROL (BUILD FEP-PROC-CONTROL 

LBUS-RESET "Lbus Reset" NOT-CLEAR-ERRORS "Clear Errors")) 
(SETG FEP-PROC-CONTROL (BUILD FEP-PROC-CONTROL))) 

(DEFUN RESET-nPSC 

;: First reset all 4 mpsc channels 
(URITE-nP£C-REG nPSC-0-A 8 38) 
(URITE-nPSC-REG nPSC.0-B 8 38) 
(URITE-riPSC-REG HPSC-l-A 8 38) 
(URITE-nPSC-REG nPSC-l-B 8 38) 
(URITE-nPSC-REG nPSC-8-A 2 5) 
(URITE-nPSC-REG tlPSC-l-B 2 5)) 

;; Two functions to hack the Bpscs, First write the register select then 

;; urite/read the selected register* 

(DEFUfJ URITE-nPSC-REG ({nPSC tIPSC HODE REF) (REG BYTE) (VAL BYTE)) 

(SETQ (CONTROL MPSC) REG) 

(SETQ (CONTROL HPSC) VAL)) 

(DEFUN (READ-nPSC-REG BYTE) ((flPSC flPSC nOOE REF) (REG BYTE!) 
(SETQ (CONTROL HPSC) REG) 
(CONTROL MPSO) 

(DEFLIN (READ-LBUS-BOARD-ID BYTE) ((BOARD UORD) (ID-LOC UORD)) 
(LET ((ADDR (DPB (LONG BOARD) «ro2385 (LSH (LONG ID-LOC) 2))) 
((VAL LBUS-UORD))) 
(SETQ FEP-BOARD-ID-CONTROL 

(CHAfiGE FEP-BOARD-ID-CONTROL FEP-BOARD-ID-CONTROL NOT-ID-REQ "Lbus ID Req")) 
(SETQ VAL (READ-LBUS ADDR)) 
(SETQ VAL (READ-LBUS ADDR)) 
(SETQ FEP-BOARD-ID-CONTROL 

(CHANGE FEP-BOARD-ID-CONTROL FEP-BOARD-ID-CONTRDL NOT-ID-REQ D) 
(BYTE (DATA VALM)) 

(DEFUN STOP-HACHINE 

(URITE-SQ-CTL-TO-STOP-nACHl^€)) 

(DEFUN SINGLE-STEP -HACHINE ((NTIHES UORD)) 

(RESTORE-STATE) 
(LOOP REPEAT NTiriES 

UNTIL (nACHINE-ERROR-P) 

DO (STEP-ttACHINE MT)))) 

(DEPUTE START-riACHINE 
(nC-ERROR-RESET) 
(RESTORE-STATE) 

(STEP-MACHINE MT)) ;Get past any current error (e.a. a breakpoint) 

(URITE-SQ-CTL-TO-START-nACHlNE (PARTS-ENABLE T))) 
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;Clock controls 

;lf ENABLE-TASK is off (implying "forced task") then »ake sure we don*t task 

;suitch by making the forced task be the current task. 
(DEFUN URITE-SQ-CTL ( (VAL 5Q-CTL) ) 

(UHEN (NOT (BIT-TEST (BUILD SQ-CTL ENABLE-TA5IC "Enabte-Task") VAL)) 

tSETQ VAL (CHANGE SQ-CTL VAL FORCED-TASK (COERCE SQ-CTL (READ-TASK))))) 

(URITE-SQ-CTL-IGNORING-TASKING-ISSUES VAL)) 

;lJrite the SQ-CTL register^ compensating for the inverted bit 

;and remembering the current value. 

(DEFUN URITE-SQ-CTL-IGNORING-TASKING-ISSUES ((VAL SQ-CTL)) 

(DISTURB-UIR) ;Thi5 usually trashes obus. 

(SETQ *CURRENT-SQ-CTL* VAL) 

(SETQ VAL (LOGXOR VAL (BUILD SQ-CTL ENABLE-SQ 1))) 

;(FDRnAT T "-^tUr i te-SQ-CTL -0." (LONG VAL)) 

(SPY-URITEIB SPY-SQ-CTL VAL)) 

(DEFUN URITE-SQ-CTL-TO-STEP-riACHINE ( (CTL-TEttPLATE SQ-CTL) ) 
;; Set up enable bits, uith step turned off 
(URITE-SQ-CTL (CHANGE SQ-CTL CTL-TEHPLATE STEP 8)) 
;; New set step; machine will clock once 
(URITE-SQ-CTL (CHANGE SQ-CTL CTL-TEHPLATE STEP D) 
;; Kill UP enable so we don't lose next time 
(URITE-SQ-CTL (CHANCE SQ-CTL CTL-TEHPLATE ENABLE-UP 8 STEP 8))) 

;Start the machine, or some parts of it, running. 

(DEFUN URITE-SQ-CTL-TO-START-nACHINE ( (CTL-TEflPLATE SQ-CTL)) 
;: Get the rest of the SQ CTL stable before setting RUN. Otherwise 
;; we can have synchronization problems that lead to things like forgetting 
;; to have write pulses during the first microinstruction executed. 
(URITE-SQ-CTL (CHANGE SQ-CTL CTL-TEHPLATE RUN 8) ) 
(URITE-SQ-CTL (CHANGE SQ-CTL CTL-TEHPLATE RUN D) 
(SETQ »nACH I NE -RUNNING* TRUE)) 

;Turn off RL^N without changing the other bits, to stop machine cleanly 
(DEFUN URITE-SQ-CTL-TO-STOP-nACHINE 

(SETQ *nACHINE-RUNNING* FALSE) 

(URITE-SQ-CTL (CHANGE SQ-CTL «CURRENT-SQ-CTL* RUN 8))) 

:;; Collect the sequencer status from various spy locations. 
(DEFUN (READ-SQ-STATUS SQ-5TATUS) 

(LET (((LOU LONG) (SPY-READ16 SPY-SQ-STATUS) ) 
((HIGH LONG) SPY-SQ-STATUS2)) 
(COERCE SQ-STATUS (DPB HIGH ;WD2ei8 LOU)))) 

;nachine stopped because not RUN, halted, or errhalt. 
;This will not be T i f the machine is waiting for memory or a trap. 
(DEFUN (nACHINE-STO?PED-P EGOLE) () 
(LET ({STS (READ-SQ-STATUS))) 

(OR (BIT-TEST (BUILD SQ-STATUS TSK-STOP 1 HALTED 1) STS) 
(NOT (BIT-TEST (BUILD SQ-STATUS -ERRHALT 1) STS))))) 

;T if there is a parity error and errhalt is enabled 

(DEFUN (nACHINE-ERROR-P BOOLE) (; 

(AND (BIT-TEST (BUILD SQ-CTL EMABLE-ERRHALT 1) *CURRENT-SQ-CTL*) 

(BIT-TEST (BUILD SQ-STATUS SPARE-LOST 1 GC-HAP-LOST 1 TYPE-tlAP-LOST 1 PAGE-TAG-LOST 1 

AHEn-LOST 1 BHEn-LOST 1 MC-LDST 1 AU-LOST 1 HALTED 1 
CT0S1-L03T 1 CT0S2-L0ST 1 TSKH-LDST 1 UIR-PAR-EVEN 1) 
(READ-SQ-STATUS)))) 

;nicroinstruct ion and controI-«emory stuff 

(DEFUr^ READ-UIR ( (RTN n I CRO INSTRUCT! ON nOOE REF) ) 
(SETF RTN SPY-CnEn) 

; (FORMAT T "-tOJr i te-c»em-wd uud - ^. " RTNJ ) 
) 

(DEFLtJ URlTE-CnEn-UO ( (UO niCROINSTRUCTIQN nODE REF)) 
;(FORnAT T •'-tURITE-CnEfl-UD UUD - -U. " UD) 
(SETF SPY-CnEn UO) ) 
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(DEFUN URITE-UIR ((UO niCROINSTRUCTION RODE REF)) 
(DISTURB-UIR) 
(URITE-CnEn-UD UD) 

; (WRITE -SQ-CTL (CHANGE SQ-CTL «CURRENT.Sa.CTL« RUN ENABLE-CnEfl 8)) ;stop machine 
(STEP-nACHIf4E MUIR))) 

(DEFUN ADDRESS-CPlEn ( (ADDR UORD)) 
(LET (((UUORD niCROINSTRUCTION))) 

(SETF UUDRD (BUILD niCROlNSTRUCTION CPC NAF)) 
(ALTER niCROINSTRUCTICN UUORD NAF ADDR) 
(URITE-UIR UUORD) )> 

(DEFUN READ-Cnnn ((ADDR UCRD) (UUD niCROlNSTRUCTION nOOE REF)) 
(ADDRESS-CriEn ADDR) 
(STEP-nACHINE ' (UIR CflEn) ) 
(READ-UIR UUD)) 

<DEFUf4 URITE-CnEn-AND-PARITY ((ADDR UORD) (UUD MICROINSTRUCTION RODE REF)) 
; (format t "^XUr i te-coiem loc • **0,' va( - *^. " addp uud) 
(ADDRESS-CRER ADDR) -SET UP ADDRESS LINES 

(URITE-CRER-UO UUD) 

(URITE-SQ-CTL (BUILD SO-CTL CRER-URITE D) 
(URITE-SQ-CTL (BUILD SQ-CTL) ) ) 



SET UP VALUE TO BE URITTEN 
URITE-PULSE ON 
URITE PULSE OFF 



(DEFUN URITE -CRER ((ADDR UORD) (UUD RICROINSTRUCTION RODE VALUE)) 
(PUT-ODD-PAR I TY-ON-UUORD UUD) 
(URITE-CREn-AND-PARITY ADDR UUD)) 



;CPC, NPC, and OPC history 

;Read NPC via the NEXT CPC tinea 
(DEFUN (READ-NPC L0r4G) 

(URITE-UIR (BUILD RICROINSTRUCTION CFC NPC>> 

(LOGAND 37777 (SPY-REAOIS SPY-NEXT-CPC) ) ) 

;Read CPC by exchanging €PZ and NPC, reading NPC, then exchanging them back 
fOEFUN (READ-CPC LONG) O 

(URITE-UIR (BUILD RICROINSTRUCTION CPC NPC SPEC "NPC Ragic" NPC 2 RAGIC 3)) 

(STEP-RACHINE • (SO) ) 

(PRXl (LOGAND 37777 (SPY-READ16 SPY-NEXT-CPC) ) 
(STEP-RACHINE MSQ)))) 

(DEFUN (READ-NEXT-CPC LONG) 

(LOGAND 37777 (SPY-READIG SPY-NEXT-CPC))) 

;CPC and NPC need to be written together 

;Urite them bu executing jump microinstructions to load CPC, and loadina NPC from CPC 

(DEFUN URITE-CPC-AND-NPC ((CPC LONG) <NPC LONG)) 

(DISTURB-SEQUENCER) ?Uhy not this? 

(CONO ((. NPC (DPS (1+ CPC) (BYTE 8 d) CPC)) ;UsuaI case 

(URITE-UIR (BUILD RICROINSTRUCTION CPC NAF NAF (PROGN CPC) NPC "Next CPC+1")) 
(STEP-RACHINE '(SO))) 
(T 
(URITE-UIR (BUILD RICROINSTRUCTION CPC NAF NAF (PROGN NPC))) 
(STEP-RACHINE * (SO)) 
(URITE-UIR (BUILD RICROINSTRUCTION CPC NAF NAF (PROGN CPC) 

SPEC "NPC Ragic" NPC RAGIC 3)) 
(STEP-RACHINE '(SQ))))) 

;Uriting them separately... 
(DEFUN URITE-CPC ((VAL LONG)) 

{(DISTURB-SEQUENCER) 
(URITE-CPC-AND-NPC VAL (READ-NPC))) 

(DEFUN URITE-NPC ((VAL LONG)) 
; (DISTURB-SEQUENCER) 
(URITE-CPC-AND-NPC (READ-CPC) VAL)) 

(DEFUN COPY-OUT-OPCS 
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(LOOP FOR (INDEX UORD) BELOU 28 

FOR (I UORD) - (LOGAND (1- INDEX) 17) 

DO (SETF (AREF *SAVED-OPCS« I) (UORD (AREF SPY-OPC 0)))) 
(LOOP FOR (INDEX UORD) BELOU 20 

FOR (I UORD) - (LOGAND (1- INDEX) 17) 

DO (SETF (AREF *SAVED-OPCS* I) (DPS (UORD (AREF SPY-OPC D) 

<rOiei8 (AREF *SAVED-OPCS* I)))) 
(SETQ *OPCS-SAVED« TRUE)) 

;;; This interacts uith state saving, Ub want to copy out the OPC's before 
;;; single stepping the machine. 
(DEFUN (READ-OPC LONG) ( (N LONG)) 

(UNLESS *0PC5-SAVED* (COPY-OUT -OPCS) ) 

(AREF »SAVED-DPCS» (LOGAND N 17))) 
;ContPol stack 
(DEFUN (READ-CSP LONG) (} 

(DISTURB-SEQUENCERl 

(READ-CSP -INTERNAL)) 

(DEFUN (READ-CSP- INTERNAL LONG) 

(URITE-UIR (BUILD niCROINSTRUCTION SPEC "NPC Haoic" HAGIC 1 AHUA tt.U 3G 5 1) 

MEn 1 AHRA-SEL 3 AHRA 2108 XY8U3-SEL ALU XSUS BnUA 377)) 
(STEP-nACHINE MOP SQ) ) 

(FORHAT T ^--X Read csp: 377«b - -0" (DATA (READ-BHEn 377))) 
(LD8 (BYTE 4 16.) (DATA (READ-BdEH 377)))) 

; Note that this iiust step the DP. because the decode of the 5EQ field is 

; inhibited bu NOP 

(DEFUN URITE-CSP ( (VAL LONG)) 

(DiSTlf^B-SEDUENCER) ;Bothering CSP, and anyway going to garbage CPZ and NPC 

(LET ((DIFF (- VAL (READ-CSP-INTERNAL) ))) 
(UHEN (NOT (2ER0P DIFF)) 

(URITE-UIR (BUILD H I CRO INSTRUCT I ON SEQ PUSHJ)) 

(LOOP REPEAT (LOGAND DIFF 17) DO (STEP-HACHINE MSQ DP)))))) 

;Thi8 location is replaced by the IFU data by the hardwarco In order to 
$iiake the memory diagnostic uork, ue ui I I sinulate this location, 
(DEFVAR *CST<-17» LONG) 

;;; llacpo to setup machine to address an arbitrary CST< location. 

;Notc: »ust write the task first, then the CSP, otherwise the tasking logic 

: saves and restores the CSP when we switch tasks. 

<DEFLILPJ\CRD ADDRE5S-CSTK (ADR «BODY BODY) 

MUITH-TASK (LDB (BYTE 4 4) ADR) : implies (DISTURB-SEQUENCER) 

(URITE-CSP (LDB (BYTE 4 0) ADR)) 

.•BODY)) 

(DEFLW (READ-CSTK LONG) ((ADR LONG)) 
(IF (. ADR 17) *CSTK.17« 
(ADORESS-CST< ADR 

(URITE-UIR (BUILD niCROINSTRUCTION CPC CTOS) ) 
(LOGAND 37777 (SPY-READ16 SPY-NEXT-CPC) ) ) ) ) 

(DEFUN (READ-CSTK-AND-PARITY LONG) ((ADR LONG)) 
(IF (- ADR 17) *CSTK-17* 
(A0DRES3-CSTK ADR 

(URITE-UIR (BUILD niCROINSTRUCTION CPC CTOS)) 
(LET ((VAL (LOGAND 37777 (SPY-REAOIS SPY-NEXT-CPC) ) ) ) 
(SETQ VAL (DPB (UORD SPY-CTOS-HIGH) (BYTE 2 14.) VAL)) 
VAL)))) 

(DEFUrJ URITE-CSTK-AND-PARITY ((ADR LONG) (VAL LONG)) 
(IF (. ADR 17) (SETQ *CSTK-17* VAL)) 
(ACDRES5-CSTK (DPB (1- AOR) (BYTE 4 0) ADR> : saves NPC 

;; This microinstruction writes NPC with VAL and makes sure it stays that way 
;; Note that CST< w\ n be written hundreds of times until UP-enable clears 
(URITE-UIR (BUILD niCROINSTRUCTION CPC NAF NPC "Next CPC+1" 

NAF (DPB (1- VAL) (BYTE 8 0) VAL))) 
(STEP-nACHINE ' (SQ UP)))) -.Always writes CSTKtCSP+l] 
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(DEPUN URITE-CSK ((ADR LONG) (VALLONG)) 

(LOOP FOR (BIT LONG) - 1 THEN (ASH BIT 1) UfJTIL (- BIT 2dd) 
WITH (PI LONG) - 1 UITH (P2 LONG) - 1 
_ WITH (HIGH LONG) - (ASH VAL -7) 
UHEN (BIT-TEST BIT VAL) 

DO (SETQ PI (LOGXOR PI D) 
UHEN (BIT-TEST BIT HIGH) 

DO (SETQ P2 (LOGXOR P2 D) 
FINALLY (URITE-CST<-AND-PARITY ADR (DFB P2 (BYTE 1 15.) (DPB PI (BYTE 1 14.) VAL))))) 

(DEFUN (READ-CTOS LONG) 

(URITE-UIR (BUILD n I CRO INSTRUCT I ON CPC CTOS) ) 
(LET ((VA L (READ-NEXT- CPC))) 
(SETQ VAL (DPB (LOTJG SPY-CT05-HIGH) (BYTE 2 14.) VAL)) 
VAL)) 

(DEFUN CLEAR-CST< 

(LOOP FOR (AODR LONG) BELOU 488 

DO (URITE-CSTX: ADDR 8))) • 

;Task state Bemory 

(DEFUfJ (READ-TASK LO^:G) (LOGANO SPY-TASIC 171) 



(DEFL»r4 URITE-TASK ((VAL LONG)) 
(IF «SAVE-STATE* 

(REST0RE-5EQUENCER)) 
(URITE-TASK-IGNORING-STATE-SAVING VAL)) 

(DEFUN URITE-TASIC-IGNORING-STATE-SAVING ((VAL LONG)) 
;; Set forced- task field in SQ-CTL 

(LET ((SQ (BUILD SQ-CTL ENABLE-TASiC 8 FORCED-TASK (COERCE SQ-CTL VAL) ENABLE-SQ 1))) 
;? Nop instruction 
CURITE-UIR (BUILD MICROINSTRUCTION)) 
;; Nou clock machine tuice to complete the task suitch 
(LOOP REPEAT 2 

DO (URITE-SQ-CTL-IGNORING-TAS)CING-ISSUES SQ) 

(URITE-SQ-CTL-IGNORING-TASKING-ISSUES (CHANGE SQ-CTL SQ STEP 1))) 
(URITE-SQ-CTL-IGNORING-TASKING-ISSUES SQ) ) ) 

jClear all task uakeups and put processor into task 8 
(DEPUTE RESET-TASK ((TASK UORD)) 
(UlTH-TASK TASK 

CURITE-UIR (BUILD MICROINSTRUCTION SEQ DISMISS)) 

(STEP-MACHINE ' (SQ DP)))) 

(DEFUN RESET-TASKS 

;; TASK 3 REQ from the FEP gets cleared by resetting the Lbus, 

:; just tike those from I/O devices. Clear the software- task wakeups. 

(RESET-TASK 1) (RESET-TASK 2) (RESET-TASK 5) (RESET-TASK 6) 

(URITE-TASK 8)) 
jThis module is in charge of the DP board 

(DEFUN URITE-DP-COKTROL-REG ((VAL LONG)) 
(URITE-LONG-INTO-MD VAL) 

(URITE-UIR (MD-MICROINSTRUCTION ALU XBUS SPEC "Load DP CtD) 
(STEP-MACHINE * (DP))) 

(DEFUN URITE-BYTE-R ((VAL LONG)) 
(URITE-LONG-INTO-MD VAL) 

(URITE-UIR (MD-Mi CRO INSTRUCT I ON ALU XBUS SPEC "Load R" MAGIC 8)) 
(STEP-MACHINE ' (DP))) 

(DEFUf^ (READ-BYTE-R LONG) 

(URITE-UIR (BUILD MICROINSTRUCTION SPEC "Crocks to Ybus" ALU ALUS AMUA 8)) 
(LDB (BYTE 5 24.) (DATA (READ-OBUS) ) ) ) 

(DEFUN URITE-BYTE-S ((VAL LONG)) 
(URlTE-LONG-INTO-rC VAL) 

(URITE-UIR (MO-MICROINSTRUCTIDN ALU XBUS SPEC "Load S")) 
CSTEP-MACHINE MDP))) 
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(DEFUN (READ-BYTE-S LONG) i) 

(URITE-UIR (BUILD fl I CRO INSTRUCT ION SPEC "Crocks to Ybus" ALU ALUB AflUA 1 11.)} 
(LOB (BYTE 5 24.) (DATA (READ-OBUS) ) ) ) 

(DEFUn'uRITE-XBAS ((VAL LONG)) 
(URITE-LONG-INTO-nO VAL) 

(URITE-UIR (HD-niCROINSTRUCTION ALU XBUS SPEC "Load XBAS**)) 
(STEP-HACHir^ • (DP))) 

(DEFUN (READ-XBAS LONG) 
^(REAO-ArtEn-ADOR 2 2.9)) 

(DEFUN (READ-ArtEn-ADDR LONG) ( (AHRA-SEL LONG) (AMRA LONG)) 
;; Set up microinstruction that causes the effective address to be continuously 
;; clocked into AIIEP! UA and continuously brought out to Obu5<9:ll> 

(URITE-UIR (BUILD niCROINSTRUCTICN AHRA-SEL (PROGN AHRA-SEL) AHRA (PROGN AtlRA) ATWA-SEL 2 
SPEC "Crocks to Ybus" AHUA 1_11. ALU ALUS)) 

(LOGAND (REA0-0BUS-L0N_G)_7777)} 

:Reads just 3S bits 

(DEFLfN (READ-AHEn LBUS-UORO) ( (ADR LOf.'G) ) 

(URITE-UIR (BUILD MICROINSTRUCTION ATIRA ADR ALU XBUS OBUS-CDR ABUS OBUS-HTYFE ABUS) ) 
(READ-OBUS)) 

;net'jrns all 40 bits (including the parity bits) 
(DEFUN (n£AO-Ar£n-AND-PARITY LBUS-UORD) ((ADR LONG)) 
(URITE-UIR (BUILD HICROINSTRUCTION AriRA ADR ALU XBUS)) 

(LET {(ANS (READ-OBUS))) -Lou 32 bits. Type and cdr are random 

(URITE-UIR (BUILD HICROINSTRUCTION AHRA ADR SPEC "Crocks to Ybus" 
BYTE-FUNC 3 rtAGIC AHUA U. U 24 7 5) 
ALU ALUS)) 
(SETF (ECC+HIGH ANS) (LOGAND /rtD377 (UORD (READ-OBUS-LONG)))) ;High 4 bits and paritu bits 
ANS)) 

;Urites 36 bits, hardware chooses parity bits 
(DEFUN URITE-AMEn ((ADR LONG) (VAL LBUS-UORD)) 

(URITE-rtD VAL) 

(URITE-UIR (RD-niCROir;STRUCTIDN ALU XBUS OBUS-HTYPE ABUS OBUS-CDR ABUS AHUA-SEL 8 AHUA ADR)) 

(STEP-HACHINE '(DP UP))) 

(DEFUN (READ-BHEn LBUS-UORD) ( (ADR LONG) ) 
(URITE-UIR (BUILD niCROtfiSTRUCTION 

XY3US-SEL 1 ALU XBUS OBUS-HTYPE BBUS OBUS-CDR BBUS BPIRA ADR)) 
:(LET (((UUD niCROINSTRUCTION) ) ) (READ-UIR UUD) (FORPIAT T "-^tUir - ^" UUD) ) 
(READ-OBUS)) 

:Returns all 48 bits (including the parity bits) 

;Fakes the bottotn 8 locations (macroinstruct ion constant) so address test ui 1 I win 
(DEFUN (READ-BflEn-AND-PARITY LBUS-UORD) ((ADR LONG)) 
;(IF (< ADR 18) (AREF ^BHEH- INACCESSIBLE-SECT I ON* ADR) 

(UtRITE-U!R (BUILD niCROINSTRUCTION BHRA ADR XYBUS-SEL 1 ALU XBUS OBUS-HTYPE BBUS)) 
(LET ((ANS (READ-OBUS))) -Low 34 bits 

(URITE-UIR (BUILD niCROINSTRUCTION BnRA ADR SPEC "Crocks to Ybus" 
BYTE-FUNC 3 ttAGIC 8 AttUA #. (+ 22 5 5 1 11.) 
ALU ALUB)) 
(SETF (ECC+HIGH ANS) 

(DPB (LOGAND (UORD (READ-OBUS-LONG)) 77) ;High 2 bits and paritu bits 
(BYTE 6 2.) (ECC+HIGH ANS))) 
ANS) ) 

;Urite3 3G bits, hardware chooses parity bits 
(DEFUN URITE-BHEn ((ADR LONG) (VAL LBUS-UORD)) 

: (FORnAT T "^^B ^ M." ADR VAL) 

(URITE-nO VAL) 

(URITE-UIR (nO-niCROINSTRUCTION ALU XBUS OBUS-HTYPE ABUS OBUS-CDR ABUS 

SPEC 14 rtAGIC 10 ArtUA ADR SnUA ADR)) ;Extended BrtUA 

(STEP-rtACHINE ' (DP UP))) 

(DEFUN (READ-TYPE-nAP LONG) (.(ADR LONG)) 

(LET ((LBUD (LONG-INTO-LBUS-UORO (ASH (LDB (BYTE 4 8) ADR) 28.)))) 

(SETF (ECC+HIGH LBUD) (UORD (LOB (BYTE 2 4) ADR))) 

(URITE-nO LBUD)) 
(URITE-UIR (nO-n I CRD INSTRUCT I ON SPEC "Crocks to Ybus" BYTE-FUTC 3 rtAGIC 8 
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AHUA n. (+ 34 33) ALU ALUB 
TVP£-nAP.SEL (LDB (BYTE S 6) ADR))) 
(LOGAND 17 (DATA (READ-OBUS) ) ) ) 

;Smashes 377«6 (well, so does everything) 

;Harduare does not compute parity 

(DEFUN URITE-TYPE-HAP ( (ADR LONG) (VALLOTJC)) 

(SETQ VAL (INSERT-ODD-PARITY VAL 3)) 

(URITE-TYPE-riAP-AND-PARITY ADR (INSERT-ODD-PARITY VAL 3))) 

(DEFUN URITE-TYPE-riAP-AND-PARITY ((ADR LONG) (VAL LONG)) 
(URITE-BHEn 377 (LONG-INTO-LBUS-UORD VAL)) 

(LET ((LBUD (LONG-INTO-LBUS-UORD (ASH (LDB (BYTE 4 3) ADR) 28.)))) 
(SETF (ECC+HIGH LBUD) (UORO (LDB (BYTE 2 4) ADR))) 
(URITE-rtD LBUD)) 
; (FORHAT T "-vt^.T *- *0, MD - *0, 377«B - -0 ' 
: ADR VAL (DATA (READ -HO) ) (DATA (READ-BttEn 377))) 

(URITE-UIR (nO-niCROINSTRUCTION TYPE-HAP-SEL (LDB (BYTE 6 S) ADR) 

BflRA 377 SPEC "Unite TYPE//GC •em" HAGIC 2)) 
(STEP-rUCHINE '(DP W))) 

(DEFLfN (READ-GC-HAP LONG) ((ADR LONG)) 
(URITE-LONG-INTO-nO (ASHL ADR 14.)) 
(URITE-UIR (nO-niCROINSTRUCTION SPEC "Crocks to Ybus" BYTE-FUNC "Genera!" PIAGIC 

APTUA n. (+ 30 3_5) ALU ALUB)) 
(LOGAND 17 (DATA (READ-OBUS) ) ) ) 

;Hapduare does not compute parity 

(DEFUN URITE-GC-HAP ((ADR LONG) (VAL LONG)) 

(URITE-GC-MAP-AND-PARITY ADR (INSERT -ODD-PARITY VAL 3))) 

(DEFUN URITE-GC-HAP-AND-PARITY ((ADR LONG) (VAL LONG) ) 
(URITE-BHEn 377 (LONG-INTO-LBUS-UORD VAL)) 
(UR I TE -LONG- I NTO-nO (ASHL ADR 14.)) 

(URITE-UIR (nO-niCROINSTRUCTION BflRA 377 SPEC "Unite TYPE//GC Bem" riAGIC D) 
(STEP-rUCHINE • (DP UP))) 
(DEFUN (REAO-STAC<-POINtER L0?4G) 1) 

(URITE-UIR (BUILD MICROINSTRUCTION AflRA-SEL 3 AHRA 0^ ALU XBUS 

OSUS-LTYPE MAGICS flAGIC OBUS-HTYPE *'Conot 0" 

Q8U3-CDR "Const 0")) 
(DATA (READ-OBUS))) 

(DEFUN (READ-FRAnE-POINTER LONG) 

(URITE-UIR (BUILD HI CRO INSTRUCT I ON AHRA-SEL 3 AtlRA 1 3 ALU XBUS 

03US-LTYPE nAGICJV riAGIC 0BU3-HTYFE "Const 0" 

OBUS-CDR "Const 0")) 
(DATA (READ-03US))) 

(DEFUN URITE-STAC<-POINTER ((VAL LONG)) 
(URITE-LONG-INTO-nO VAL) 

(URITE-UIR (riD-niCROINSTRUCTION ALU XBUS SPEC "Load STKP")) 
(STEP-HACHINE MOP))) 

(DEFUN URITE-FRAME-POINTER ((VAL LONG)) 
(URITE-LONG-INTO-riD VAL) 

(URITE-UIR (riD-niCROINSTRUCTION ALU XBUS SPEC "Load FRfF")) 
(STEP-HACHINE * (DP))) 

(DEFUN DATA-TO-OBUS ((VAL LBUS-UORD)) 
(URITE-MD VAL) 
(URITE-UIR (flD-niCROINSTRUCTION ALU XBUS OBUS-HTYPE AfiUS OBUS-CDR ABUS))) 

;j; Bit 11 of AMUA selects which set of crocks to read, 
(DEFUTJ (READ-CROCKS LONG) ((ADR LONG)) 

(URITE-UIR (BUILD HI CRD INSTRUCT I ON AHUA (ASH ADR U.) 

SPEC "Crocks to Ybus" ALU AluB)) 

(DATA (READ-OBUS))) 

(DEFUN URITE-VriA ((VAL LONG)) 
(DI5TUR3-VnA) 

(URITE-BriEn 377 (LONG-INTD-LBUS-UORD VAL)) 
(URITE-UIR (BUILD HI CRD INSTRUCT I ON BtlRA 377 XYBUS-SEL 1 ALU XBUS MEH 5)) 
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(STEP-HACHINE '(DP))) 

(CEFUN*. (REAO-niCRODEVICE LBUS-UORD) ((SLOT LOfJG) (SUBDEVICE LONG)) 
(URITE-UIR (BUILD fllCROINSTRUCTION AHRA-SEL 1 

AHRA 180 nEn 1 

AnUA (+ (LSH SLOT 5) SUBDEVICE) 

ALU XBUS OBUS-HTYPE ABUS OBUS-CDR ABUS 

BnUA 17)) 
(STEP-nACHINE ' (DP)) 

(READ-BnED 377)) 

;;; tlC spy bus inter faces 

(DEP.IO SPY-nC-CONTROL nC-CONTRDL) ;Urite only 

(DEF-IO SPY-nC-ID BYTE) -ID indexed by low 5 bits of SPY-flC -CONTROL 

<DEF-IO SPY-nC-ERRGR-STATUS nC-ERROR-STATUSi 

(DEF-IO SPY-ECC-SYNDROnE BYTE) ;S-8 inverted syndrome bits, 7 error flag 

(DEF-IO SPY-ECC-ADDRESS BYTE) ;l-8 ADDR<l-8>, 7-2 ADDR<23-18> 

(DEF-IO SPY-nC-STATUS fIC-STATUS) 

(DEF-IO SPY-LBU5-CGNTR0L UORD) ;Lbus control 

(DEFVAR «LAST-nC-CONTROL* nC-CONTROL (BUILD flC-CONTROD) 
■ IDEFYARjtflC-CDN TROL-UH ILE-RUNNING* flC-CONTROL (BUILD nC-CONTROL) ) 

;;; Ur i te mc-contpol compensating for inverted bits, and pcmembeptng the value written. 
(DEFUfJ URITE-nC-CONTROL ((VAL nC-CONTROD) 

(5ETQ SPY-nC-CONTROL (LOGXOR (BUILD nC-CONTROL ECC-DRIVE-DISABLE 1 ERROR-RESET 1) VAL)) 

(SETQ «LAST-nC-CONTROL« VAL)) 

(DEFUN nC-RESET 
;; Clear errors then set up standard controls 
(URITE-nC-CONTROL (BUILD nC-CQNTROL ERROR-RESET 1)} 
(URITE-nC-CONTROL »nC-CONTROL-UIHILE-RUNNING*) ) 

(DEFUN nC-ERROR-RESET (} 
;; Clear errors, leaving controls the same 
(UITH-SPECIAL-nC-CDNTROL (ERROR-RESET 1))) 

(DEFUN URITE-nO ((VAL LBUS-UORD) ) 

(UITH-SPECIAL-nC-CONTRDL (SPECIAL-LOAD-PID 1) 
(URITE-LBUS 77777777 VAL))) 

(DEFUN URITE-LONG-INTO-nO ((VAL LONG)) 
(URITE-nO (LONG-INTO-LBUS-UORD VAL))) 

;If there i s an HC board, this reads the ID MD 

(DEFUN (READ-nO LBUS-UORD) {) ;via Abus, Xbus, Obus 

(URITE-UIR (nO-niCROINSTRUCTION ALU XBUS OBUS-HTYPE ABUS OBUS-CDR ABUS)) 

(READ-OBUS)) 

(DEFUN (READ-OBUS LBUS-UORD) 

(UITH-SPECIAL-nC-CONTROL (OBUS-TO-LBUS 1) 
(READ-LBUS 77777777))) 

(DEFL'N (READ-OBUS-LONG LONG) 

(UITH-SFECIAL-nC-CONTROL (OBUS-TO-LBUS 1) 
(DATA (READ-LBUS 77777777)))) 

(DEFUN nC-ECC-DIAG-P10DE ((ON-OFF BOOLE)) 
(COND (ON-OFF 

(SETQ SPY-LBUS-CONTROL (CHANGE FEP-LBUS -CONTROL SPY-LBUS-CONTROL ECC-DIAG D) 
(URITE-nC-CONTROL (BUILD HC-CONTROL ECC-DRIVE-DISABLE 1 ECC-CORRECT-DISABLE 1))) 

(SETQ SPY-LBUS-CONTROL (CHANGE FEP-LBUS-CONTROL SPY-LBUS-CONTROL ECC-DlAG 8)) 
(URITE-nC -CONTROL (BUILD nC-CONTROL ECC-DRIVE-DISABLE 8 ECC-CORRECT-DISABLE 8))))) 

(DEFUN (READ-LBUS-AND-ECC LBUS-UORD) ( (AODR LONG) ) 
(UITH-LBUS-ECC-DIAG-nODE 
(LET (((LBU LBUS-UORD))) 

(SETQ (ADDRESS (AREF LBUS-HAP LBUS -HAP- SLOT)) (LBUS-ADDRESS-PAGE ADDR)) 
(SETF (DATA LBU) {<-SLOt>IG (AREF (AREF LBUS-DATA LBUS-tlAP-SLOT) 

(LBUS-ADDRESS-OFFSET ADDR)))) 
(SETF (ECC+HIGH LBU) (ECC+HIGH (AREF LBUS-HAP LBUS-ttAP-SLOT)) ) 
LBU) ) ) 
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(DEFUN URITE-LBUS-AND-ECC ((ADDRLONG) (LBU LBUS-UORD) ) 
(U I TH-LBUS -ECC-D I AG-HODE 
(SETQ (ADDRESS (AREF LBUS-HAP LBUS-nAP-SLOD) (LBUS-AODRESS-PAGE ADDR)) 
(SETQ (ECC+HIGH (AREF LBUS-MAP LBUS-HAP-SLOT) ) (ECC+HIGH LBU)) 
(SETF (AREF (AREF LBUS-OATA LBUS-MAP-SLOT) (LBUS-AODRESS-OFFSET ADDR)) 
(->SLONG (DATA LBU))))) 

jSaves and restores main memory locations 0,1 (which better exist!) 
(DEFUN URlTE-AN-EnU-riD ((UHICH-ONE LONG) (VAL LBUS-UORD) ) 
(DISTURB-EnU-nO-PAIR) 

(LET ( (SAVED-HAIN-nEn (REAO-LBUS UHICH-DNE) ) ) 
(URITE-LBUS UHICH-DNE VAL) 
(URITE-VHA (+ 1720038390 UHICH-DNE)) 
(URITE-UIR (BUILD RICRDINSTRUCTION MEM 2)) 
(STEP-riACHINE * (DP)) 
(URITE-LBUS UHICH-ONE SAVED-HAIN-nEn) )) 

(DEFUr; (READ-AN-EHU-MD LBUS-UDRD) ((UHICH-ONE LONG)) 

(DISTURB-VMA) 
(URITE-VHA (+ 1700000000 UHICH-ONE)) 
(URITE-UIR (BUILD niCROJWSTRUCTION AHRA-SEL 3 AttRA 2000 

ALU XBUS OBUS-HTYPE ABUS OEUS-CDR ABUS)) 
(REAO-OBUS)) 
(DEFUN (READ-VrtA LONG) 

(URITE-UIR (BUILD rtlCROlNSTRUCTiaV AHRA-SEL 3 ATIRA 2200 

ALU XBUS OBUS-HTYPE ABUS OBUS-CDR ABUS)) 

(LOGAND tfAl- (ASH 1 2S-)) (DATA CREAD-OBUSn ) ) 

(DEFUN (READ-ASN LONG) 

(URITE-UIR (BUILD ni CRD INSTRUCT I ON APtRA-SEL 3 ATTRA 2209 

ALU XBUS OBUS-HTYPE ABUS OBUS-CDR ABUS)) 
(LET ((LBUO (READ-OBUS) ) ) 

(DPB (ECC+HIGH LBUD) ;!ro0404 (LSH (DATA LBUD) -28.)))) 

(DEFUN (READ-PC LONG) 

(URITE-UIR (BUILD n I CRO INSTRUCT I ON AHRA-SEL 3 ATTRA 2A00 

ALU XBUS OBUS-HTYPE ABUS OBUS-CDR ABUS)) 
(DATA (READ-OBUS) ) ) 

; Smashes VHA 

(DEFUN miTE-PC ((VAL LONG)) 
(OISTURB-VHA) 

; (SETQ «vnA-SAVEO* FALSE) 
(URITE-BPtEn 377 (LONG-INTO-LBUS-UDRD VAL)) 
(URITE-UIR (BUILD HI CRO INSTRUCT I ON BHRA 377 XYBUS-SEL 1 ALU XBUS OBUS-HTYPE BBUS 

riEH 1 AnUA (+ 1.10. 373 2) AHUA-SEL 3)) 
(STEP-rtACHINE MOP))) 

:;: These are for the convenience of state saving 
(DEFUN URITE-PHTA-ASN ((VAL LONG)) 

(OISTURB-PHTA-ASN) 

(URITE-BnEM 377 (LONG-INTO-LBUS-UORD VAL)) 

(URITE-UIR (BUILD n I CRD INSTRUCT I ON BMRA 377 XYBUS-SEL 1 ALU XBUS OBUS-HTYPE BBUS 

MEn 1 ATIUA (+ Ija. 37_5 1) ATIUA-SEL 3)) 

(STEP-ttACHINE MDP))) 

(DEFUN (READ-PHTA-ASN LONG) 

(OISTURB-VHA) 

(URITE-VHA 17.20.) ;To get the PHTB bits 

(URITE-UIR (BUILD niCROINSTRXTION SPEC "Use PHTA" ;Force PHTA to ADDR 

AnRA-SEL 3 AHRA 2300 ;Copy map output to 377«B 
ALU XBUS OBUS-HTYPE ABUS OBUS-CDR ABUS 
BnUA 377)) 

(STEP-ttACHINE ' (DP UP)) 

(LXIOR (LOGAND (DATA (READ-BnEM 377)) tfQ7777ZQZQ) ;PHTA/PHTB 

(READ-ASN))) 

(DEFUN URITE-PHTA-AND-ASN ( (PHTC-ADDR LONG) (PHTC-SIZE LONG) (ASNLONG)) 
;; phtc-size is a pouer of 2 betueen 4< and 6AK 
;; phtc-addr is a multiple of 84k 
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;; asn is an 8 bit number 

(DISTURB-PHTA-ASN? 

(LET ((PHTB (DPS (- (LDB (BYTE 4 12. J PHTC-SI2£1> IBVTE 4 12.) 8))) 
(URITE-LONG-INTO-fID (LDGWR PHTC-ADDR PHTB ASN)) 
(SETQ PHTB (DPS (- (LDB (BYTE A 12.) PHTC-SI2E)) (BYTE 4 12.) 0)) 
<URlTE-LONG-INTO-nD (LOGIOR PHTC-ADDR PHTB ASN)) 

(URITE-UIR (nO-niCROINSTRUCTION ALU XBUS OBUS-HTYPE ABUS BHUA 377)) 
(STEP-HACHINE * (DP)) 

- (URITE-UIR (BUILD HI CRD INSTRUCT I ON BHRA 377 XYBUS-SEL 1 ALU XBUS OBUS-HTYPE BBUS 

riEn 1 AnuA (+ ije, 37 5 i) amua-sel 3)) 

(STEP-HACHINE ' (DP)))) 

(ConnENT 

(DEFVAR *nAP-EXPECTED-CONTENTS* (HAKE-ARRAY 23028 ': INITIAL -VALUE 0)) 
(DEFVAR »ALLOU-nAP-SLOU-READ« T) -Set this to NIL to not try all tags 

;ReacJ and unite map. Values in the form they actually are in the RAP) (bits 0-32 only). 
jParity bit appears in 33 rather than 35 to make diagnostics happy. 
;Bit 12 of the address is for iiap A, 1 for mao B 

;C Jobber s PHTA, AS N, VHA, 0«A 
(DEFUN URITE-HAP (ADR VAL &AUX ASN) 
;; Clobber ASN with the bits that write from it 
(URITE-PHTA-AND-ASN 10200 (SETQ ASN (LDB (BYTE 8 25.) VAL))) 
;; Point VMA at the desired location 

(URITE-VHA (ASH (LOGXO?^ (LOB (BYTE 12. 0) ADR) (LDB (BYTE 4 0) ASUi) 8)) 
:; Put Abus data into HD 

(WRITE -no (LOGIOR (ASH (LDB (BYTE 16. 0) VAL) 8) 
(LDB (BYTE 1 16.) VAL) 
(ASH (LDB (BYTE 8 17.) VAL) 24.))) 
;; Urite it 

(URITE-UIR (nO-niCROINSTRUCTION ALU XBUS OBUS-HTYPE ABUS AHUA-SEL AnUA O) 
(STEP-HACHINE ' (DP)) 
(URITE-UIR (BUILD niCROINSTRUCTION AMRA ALU XBUS OBUS-HTYPE ABUS 0BU5-CDR AEUS 

MEH 1 AflUA (+ 1J0. 37.5 5 (LDB (BYTE 1 12.) ADR)) 
AnUA-SEL 3)) 
(STEP-r.ACHINE MDP) ) 
(ASET VAL *f1AP-EXPECTED-C0NTENTS« ADR)) 

;Read the map through various strateqems. 



(DEFUrj READ-HAP (ADR) 
:; Get e>;pected contents of fields not directly readable 
(LET ((VHA-TAG (LDB (BYTE 8 17.) (AREF *nAP-EXPECTED-CONTENTS« ADR))) 
(ASN-TAG (LDB (BYTE 8 25.) (AREF *nAP-EXPECTEO-CONTENTS* ADR)))) 
:: Enable desired map 
(UITH-SPECIAL-nC-CONTROL (HAP-A-DISABLE (LDB (BYTE 1 12.) ADR) 

HAP-B-DISABLE (LOGXOR (LDB (BYTE 1 12.) ADR) D) 
(OR (AND (- (LDB (BYTE 4 4) VriA-TAG) 17) 

(AREF *nAP-EXPECTED-CONTENTS* ADR)) 
(READ-HAP-TRY ADR VhA-TAG ASN-TAG) 
(READ-nAP-TRY-BIT-TOGGLES ADR VHA-TAG ASN-TAG) 

(Ar;0 *ALLOU-nAP-SLOU-REAO« (READ-HAP-TRY-EVERYTHING ADR VHA-TAG ASN-TAG)) 
(PRCGN (FORHAT T "-^Unable to read map loc -0 no matter what;^ 
Resume to return correct contents 'vQ" 
ADR (AREF «nAP-EXPECTED-CDNTENTS* ADR)) 
(PRrNT-BJT-nAS< (AREF «nAP.EXPECTED-CONTENTS* ADR) "; bits ") 
(BREAfC REAQ-nAP} 
(AREF *nAP-EXPECTED-CONTENTS* ADR)))))) . 

;Read map, return contents or NIL if no hit 
(DEFUN READ-HAP-TRY (ADR VHA-TAG ASN-TAG) 
;; Point ASN at the desired location 
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(URITE-PHTA-AND-ASN 8 18330 ASN-TAG) 
;; Point VHA at the desired location 
(URITE-VHA (ASH (LOGXOR (LDB (BYTE 12. 0) ADR) 

(LDB (BYTE 4 0) ASN-TAG) 
(ASH (8-BIT-REVERSE VHA-TAG) 4) 
(ASH VHA-TAG 12.)) 
8)) 
;; Read the map 
(LET ((HAP-SEL (1+ (LD3 (BYTE 1 12.) ADR))) 

(MAP (PROGN (URITE-UIR (BUILD n I CRD INSTRUCT I ON AtlRA-SEL 3 AHRA 2300 

ALU XBUS OBUS-HTYPE ABUS 03US-CDR ABUS)) 
(REAO-DBUS)))) 
(AND (« (LDB (BYTE 2 32.) MAP) tlAP-SEL) ;Read from correct map if hit 
(LOGIOR (LDB (BYTE 16. 8) flAP) 515-0 PPN 

(ASH (LDB (BYTE 1 34.) MAP) 16.) ; 16 Unite protect 
(ASH (LDB (BYTE 8 24.) MAP) 17.) ;24.17 VMA tag 
(ASH ASN-TAG 25.))))) ;32-25 ASN tag 

(DEFU:,! READ-MAP.TRY-BIT-TDGGLES (ADR VMA-TAG ASN-TAG) 

(FORMAT T "-^tunable to read map, trying toggling bits in tag fields.]-!") 
(PROG READ-MAP-TRY-BIT-TOGGLES (TEM) 
.(Cn Tin£S (18) 

(IF (SETQ TEM (READ-MAP-TRY ADR (LOGXOR VMA-TAG (ASH ID) ASN-TAG)) 

(RETURN-FROM READ-MAP- TRY -BIT -TOGGLES TEM))) 
(DOTIMES (I 8) 

(IF (SETQ TEM (READ-MAP-TRY ADR VMA-TAG (LOGXOR ASN-TAG (ASH 1 I)))) 

(RETURN-FROM READ-MAP-TRY-BIT-TOGGLES TEM))))) 

(DEFUN READ-MAP-TRY-EVERYTHING (ADR VMA-TAG ASN-TAG) 

l^S^I-"^ '-^[Unable to read map, trying ail possible values in tag fields. ]-vX-) 
(PROG READ-MAP-TRY-EVERYTHING (TEM) 
(DOTIMES (I 40C) 

(IF (SETQ TEM (READ-MAP-TRY ADR I ASN-TAG)) 

(RETURN-FROM READ-MAP-TRY-EVERYTHING TEM))) 
(DOTIMES (I 4C3) 

(IF (SETQ TEM (READ-MAP-TRY ADR VMA-TAG I)) 

(RETURN-FROM READ-MAP-TRY-EVERYTHING TEM))))) 

(DEFUN 8-B IT-REVERSE (NUMBER) 
(LOOP FOR I FROM TO 7 

SUMMING (ASH (LOGANO (ASH NUMBER (- I)) 1) (-7 1)))) 

State saving 

Explicit read and ur i te from console 

Here we want to tnte^.^ct with the state-saving, rather than primitively 

accessing ths hardware 

tt\ 

Uir -» Uir, Ofcus, Next-cpc, Sequencer-status 

Sequencer -* Npc, Cpc» lasK, Csp 

Vma 

10 MD 

EMU MDs 

PHTA-ASN 

Variables control ing state saving. 
*Save-state* 

True The first time an internal register is written, it's previous 

value is saved and will be restored by "restore". 
False No hardware values are saved. 

*read-state« 

True Reads from tne console read from saved state iff the 

hardware has been written since the last "restore". 
False Reads from the console always read from the hardware. 

Functions that affect state saving. 

E3ve-state Save the most volatile parts of the machine, 
oi scard-state Ignore any previous saved state, 
restore-state Copy the saved state back into the machine. 
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1) No state saving at ail. Reads/Urites go directly to harduare and may cause 
arbitrary amounts of state tc be lest. 

2) Reads/LJrites both go to hardware, but if the operation requires that some 
state of the machine be trashed, that state is saved by the FEP. For 
exarpie: reading cmem uijj cause the UIR to be saved and restored when 
the machine is C-p'ed. 

2) Urites always go to hardware. Reads read either from harduare, or from 
the saved state if the hardtiare has been disturbed. 



The savino of the hardware into these variables is only done when it is 
about to be chanc^ed. 

-A- Put it back whenever we disturb it 

-2- Put it back when we next return to command level 

-3- Put it back with the :RE5T0RE command only, and have a flag in the 
status display that says it's been damaged. 

-4- Have a user-set tab iej lag tha t ch ooses between 2 and 3 
This keeps track of whether or not we think that the machine is running 

(DEFVAR&INITFUN INIT-STATE-SAViNG U 
*nA:HIN'E-RLWIN3* BOOLE FALSE 
*UP0ATE-5TATUS* BOOLE FALSE 
*SAVE-STATE* BOOLE FALSE 
j«J^EAD-STATE* BOOLE FALSE 
•UIR-SAVEO* BOOLE FALSE 
*SEQLIE\'CER-SAVED* BOOLE FALSE 
*IO-riO-SAVEO* BOOLE FALSE 
*vnA-SAVED* BOOLE FALSE 
*PHTA-ASN-SAVEO* BOOLE FALSE 
♦EnU-nO-PAIR-SAVED* BOOLE FALSE) 

(DEFVAR *SAVEO-UIR* HICROINSTRUCTION) 

(DEFVAR *SAVED-03US» LBUS-U'ORD) 

(CEFVAR *SAVED-N'EXT-CPC« LONG) 

(DEFVAR *SAVED-SC-STATUS* SQ-STATUS) 

(OEFVAR *0FC3-SAVED* BOOLE) 

(DEFVAR »SAVED-GPCS* (ARRAY LO.X IB)) 

:The NFO (and hence CFC) , CSP, and TASK must be disturbed to fool with the 
:micrcccde control stack and the task memory. Except when doing that we 
; lejve them atone, 
(DEFVAR *SAVED-NPC* LONG) 
(OEFVAR *9AVE0-CT05* LONG) 
(DFPVAR *SAVEO-CPC* LONG) 
(DE"VAR *SAVED-C5P* LONG) 
(DEFVAR *:SAVED-TASK* LONG) 

:The T^r. 

(DEFVAR *SAVED-IO-nD* LBUS-UORD) 
(DEFVAR *SAVED-Er;U-nD-LOU* LBUS-UORD) 
(DEFVAR *3AVEn_rr,L;-r!D-HIGH* LBUS-UORD) 
(DEFVAR *SAVED-vnA* LONG) 
(DEFVAR *3AVED-PHTA-A5N* LONG) 
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(DEFUN DISCARD-STATE 
(DISCARD-UIR) 
{DISCARD-SEQUENCER) 
(DISCARD-nC) 
tSETQ «UPDATE-STATUS« TRUE)) 

(DEFUN RESTORE-STATE 
(RESTORE-rtC) 
(RESTORE-SEQUENCER) 
^RESTORE-UIR) 
(SETQ *UPDATE-STATUS« TRUE)) 

{DEFUN ENSURE-HACHINE-HALTED 
(UHEN «nACHIN£-RUNNING« 

(FORHAT T "Attempt to clobber running machine, flachine halted.") 
(URI TE-SQ-CTL-TD-STOP-HACHINE) ) ) 

;Save UIR and related regtstera (just before trashing them) 
(DEFUN DISTURB-UIR 
(ENSURE-riACHINE-HALTED) 

(UNLESS (OR *UIR-SAVED* (NOT «SAVE-STATE«) ) 
(5AVE-UIR) 
(SETQ «UPDATE-STATUS* TRUE)n 

(DEFUN SAYE-UIR 

(FDRTIAT T "^XSaving uir...") 
(SETQ *SAVED-UIR« SPY-CnEn 

*SAVED-OBUS* (READ-OBUS) 

»SAVED-NEXT-CPC« (READ-NEXT-CPC) 

*SAV£D-SQ-STATUS* (REAO-SQ-STATUS) ) 
(SETQ «UIR.SAYED« TRUE) 

;: Copg out the OPCs before we trash then by single stepping the machine. 
(UrJLESS «OPCS-SAYED« (COPY-CUT-OPCS))) 

(DEFUN RESTDRE-UIR 
(UHEN «UIR-SAVED* 

(URITE-UIR «SAVED-UIR«)) 
(SETQ *UIR-SAVED« FALSE 

*OPCS-SAVED« FALSE)) 

(DEFUN DISCARD-UIR (SETQ *U I R-SAVED* FALSE) ) 

:Save rest of sequencer 

:CaH this onlu if uou need to save CPC /NPC/CSP/TSK 

(DEFL^N DISTURB-SEQUEMCER U 
(ENSURE-HACH I NE -HALTED ) 
(UNLESS (OR »SEQUENCER-SAYED« (NOT *SAVE-STATE*) ) 

(SAVE-SEQUENCER) 

(SETQ *UPDATE-STATUS« TRUE))) 

(DEFUN SAVE-SEQUENCER i) 

(FuRHAT T "-^Saving uir...") 
(SETQ *5AVED-NPC* iREfiD-NPC} 

»SAYED-CTDS« (READ-CTOS) 

»SAVED-CPC« (READ-CPC) 

♦SAVED-TASK* (READ-TASK) 

♦SAVED-CSP* (READ-CSP. INTERNAL) 

♦SEQUENCER-SAVED* TRUE)) 

(DEFUr^ RESTORE-SEQUENCER 
(UHEN *SEQUENCER-SAVED« 

(IF (p. *SAVED-TASK« (READ-TASK)) 

(FORHAT T "Restore sequencer has lASK change out from under it.")) 
(URITE-CSP *SAVED-CSP«) 

(URITE-CPC-AND-NPC *SAVED-CPC* »5AVED-NPC«) 
(SETQ »SEQUENCER-SAVED» FALSE))) 

(DEFUN DISCARD-SEQUENCER (SETQ «SEQUENCER.SAVED« FALSE) ) 
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;DiatuPb the lO-flD (the one that REAO-MO and URITE-rtD hack) 
(DEFUN DISTURB-IO-nO 

(ENSIJRE .HACH I NE -HAL TED ) 

(UNLESS (Ofi «IO-nD-SAVED« (NOT *5AVE.STATE») ) 

(SAVE-ro-no))) 

(DEFUN DISTURB-EnU-nO-PAIR 
(Er^URE -HACH I NE -HAL TED ) 
(UNLESS (OR «£nU-nD-PAIR-SAYED» (NOT «5AVE-STATE*) } 

(SAVE-EMU-nO-PAIR) 

(SETQ »UFDATE-STATUS« TRUE) ) ) 

(DEFUN OISTURB-VHA 
(EfJSURE-riACHI NE-HALTED) 
(LWLESS (OR «vnA-SAVED« (NOT «SAVE-STATE*) ) 

(SAVE-VHA) 

(SETQ «UPDATE-STATUS* TRUE))) 

(DEFUN DISTURB-PHTA-ASN 
(ENSURE -HACH I ^iE-HAL TED ) 
(UNLESS (OR »PHTA-ASN-SAVED* (NOT *SAVE.STATE*) ) 

(SAVE-PHTA-ASN) 

(SETQ «UPDATE -STATUS* TRUE) J) 

(DEFUN SAVE-IO-nO 

(SETQ *SAVED-IO-nD« (READ-PID) 
«IO-nD-SAVED« TRUE)) 

(DEFUN SAVE-EnU-nO-PAIR 

(SETQ *SAVED-EnU-nD-LOU* (READ-AN-EnU-MD 0) 
*SAVED-EnU-nD-HIGH* (READ-AN-EnU-HD 1) 
«£nU-nD-PAIR-SAVED» TRUE)) 

(DEFUN SAVE-VfIA 

(SETQ *SAVED-VnA* (READ-VHA) 
«VnA-SAVED* TRUE)) 

(DEFUN SAVE-PHTA-ASN 

(SETQ *SAVED-PHTA-ASN* (READ-PHTA-ASN) 
•PHTA-ASN-SAVED* TRUE)) 

(DEFUN RESTORE-nC 
(UHEN «PHTA-ASN-SAVED* 

(URI TE-PHTA-ASN «SAVED-PHTA-ASN*) 

(SETQ «PHTA-ASN-SAVED* FALSE)) 
(UHEN *£nU-nD-PAIR-SAVED* 

(URITE-AN-EnU-nO »5AVED-EnU-nD-L0U*) 

(URITE-AN-EnU-nD 1 «SAVED-EnU-nD-HIGH«) 

(SETQ *EnU-nD-PAIR-SAVED« FALSE)) 
(UHEN «vnA-SAVED* 

(URITE-VHA *SAVED-VnA*) 

(SETQ «vnA-SAVED* FALSE)) 
(UHEN «IO-nD-SAVED« 

(URITE-HD *SAVED-10-nD*) 

(SETQ «IO-nO-SAV£0* FALSE))) 

(DEFUN DISCARD-nC 
(SETQ «PHTA-ASN-SAVED« FALSE 

«£nU-nD-PAIR-SAVED* FALSE 
»vnA-SAVED« FALSE 
*IO-nD-SAVED^FALSE) ) 

F:>1mach>fep>Lcons-Interface.lil .28 



;;;-«- Mode: Li I: Package: Lit; BasisrS.; Louercase: T -*- 

(include "Types-and-macros" •n3chtne»ext") 

(defatonmacro version-number '2) 
(defvar «pp-abort-f lag* boole) 
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(defvar ^checksum* uord) 

(deflilmacro tnl rne-read-pp-byte 
*(ft «pp-abort-f lag* (byte 0) 
(let {((byte byte))) 
;; Uait for next command 
(war t-f or-strobe-to-set) 
;; look for abort bit 
(cond ((bit-test p-popt 1_14.) 

(sctq «pp-abort-f lag* true) ;lou level should clean up 
(byte 0)) 
(t ;; Read the byte 
(setq byte (byte (logand Uo211 p-port))) 
; ; ack the byte 
(setq p-port (logior 1_12. 2)) 
(sctq p-popt (loglop 1.15. 1.12. 2)) 
;; uait for our ack to be accepted 
(uai t-for-strobe-to-clear) 
(setq p-port 0) 

(sctq ^checksum* ( logxcr (roti schecksum* 1) (logand #o377 (word byte)))) 
byte))))) 

(deflilmacpo defucom (name args . body) 
* (defun ,name 

(let* .(loop for (arg type) in args 
col lect (selectq type 

(byte M(, arg byte) (read-pp-byte) ) ) 
(uord '((,arg uord) (pcad-pp-uord) ) ) 
(addr *((,arg long) (read-pp-addr) ) ) 
(long '((.arg long) (read-pp-long) ) ) 
(otheruise (ferror nil "Bad argtype to def-com") ) ) ) 
(uhen (check-checksum) 

(setq *checksum« #o55555) 
4«sody 
(check-checksum) ) ) ) ) 

(defMlmacro defrcom (name args . body) 
* (defun ,name 

(let* ,(loop for (arg type) in args 
collect (selectq type 

(byte M(, arg byte) (read-pp-byte) ) ) 
(uord M(.arg uord) (read-pp-word) ) ) 
(addr '((.arg long) (read-pp-addr))) 
(long *((,arg long) (read-pp- long) ) ) 
(otheruise (ferror nil "Bad argtype to def-com")))) 
(uhen (check-checksum) 
(setq *checksuff)* UoSSSSS) 

(ur i te-pp-word , Ifep^op-number-fpom-ppocess-funct ion name)) 

••body 

(ur i te-pp-uord *checksum«) ) ) ) ) 

(defun (read-pp-byte byte) 
(in) ine-read-pp-byte)) 

(defun (read-pp-uopd uopd) 

(let ({b0 (uord (read-pp-byte))) 
(bl (uord (read-pp-byte) ) ) ) 

(dpb bl #01010 b0))) 

(defun (read-pp-addr long) 
(let ((b0 (long (read-pp-byte))) 
(bl (long (read-pp-byte))) 
(b2 (long (read-pp-byte)))) 
iti;-^t^ b2 ^02810 (dpb bl tfol010 (Idb UoZZlZ b0) ) ) ) ) ; Idb needed 'cause sign extends, 
(defun (read-pp- long long) 
(let {(b0 (long (read-pp-byte))) 
(bl (long (read-pp-byte))) 
(b2 (long (read-pp-byte))) 
(b3 (long (read-pp-byte)))) 
(dpb b3 #o3010 (dpb b2 #o2010 (dpb bl «?ol010 fo0) ) ) ) ) 
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(def 1 i Imacro inl ine-ur i te-pp-byte (byte) 
'(unless *pp-abopt-f lag* 

(let ({(byte uord) (logand #o377 (word ,byte)))) 
_ ;; assume we are going to uin and update the checksum 
(setq ^checksum* (logxor (rot) ^checksum* 1) iuord byte)}) 
;; Wait for next command 
(wai t-for-strobe-to-set) 
; : look for abort bi t 
(cond {(bit-test p-port 1_14. ) 

(setq «pp-abort-f lag* true)) ; low level should clean up 
(t (setq byte (iogiop 2_12, byte)) 
(setq p-port byte) 
(setq p-port (logiop 1.15, byte)) 
;; wait for our ack to be accepted 
(uai t-for-strobe-to-cleap) 
(setq p-popt 0)))))) 

(defun wri te-pp-byte ((byte word)) 
(inline-wpite-pp-byte byte)) 

(defun uri te-pp-uord ((word wopd) ) 
(wptte-pp-byte (Idb #oS918 word)) 
(up ite-pp-byte (tdb ^olZlB ward))) 

(defun upite-pp-addr ((addr long)) 
(loop pepeat 3 

do (wpi te-pp-byte (wopd (logand #o377 addp))) 
(setq addP (potr addp &)))) 

(defun wpi te-pp-iong ((long long)) 
(loop repeat 4 

do (wpt te-pp-byte (word (logand #o377 long) ) ) 
(setq long (rotp long 8)))) 

; (defmacro wai t-for-strobe-to-set '(loop until (rainusp p-popt))) 
; (defnacpo wai t-for-strobe-to-clear '(loop while (iiinusp p-poPt))) 

;;; Use these when we have the schedular 

(defmacro wai t-for-strobe-to-set i&optional a I low-schedule) 
( i f al low-schedule 

• (loop repeat 38080. 

until (minusp p-port) 

finally (process-wait "Strobe to set" ^'paral lel-port-strobe-set-p) ) 
'(loop until (minusp p-port)))) 

(defmacro wai t-for-strobe-to-clear (^optional a I low-schedule) 
(if al low-schedule 

' (loop repeat 30000. 

while (minusp p-port) ' 

finally (process-wait "Strobe to cicap" ^S^'papallel-popt-stpobe-cleap-p)) 
•(loop while (minusp p-poPt)))) 

(defun (paral Icl-popt-strobe-set-p boo^ei O (minusp p-port>) 
^^g:(_""Jpa^^"e'-po^^- strobe-clear-p b oole) C> (n ot (minusp p-port))) 
(defatOBimacro normal' -response 1^8.) 

idefatommacro norma t -response-w i th-data 2_S, ) 
(defatommacro jump-response 3_8,) 
(defatcramacro Ibus-read-response 4_8. ) 

(defatommacpo reset-response I0_8,) 
(defatommacro command-error-response 11_8.) 
(defatommacro bus-error-response i2_8. ) 
(defatommacro addpess-error-response 13_8.) 
(defatommacro random-trap-response 14_8. ) 

(defun Icons- inter face- top- level 
; (declare (require asm-hack)) 
(prog (((resp word)) ;responBe 

((data word)) ;ue store word data here 

((cmnd long)) .Put the 3 bits of command code here 

((addr long))) ;address to read/write from 
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(setq resp reset-response) 

(setq p-port resp) ;deskew the data 

(setq p-port (iogior resp 1_15.)} ; bg one instruction time, 
(go f irst-t iwe-oniy) 
resp 

(setq p-port resp) ;deskeu the data 

(setq p-port (Iogior resp 1_15.)) ; by one instruction time. 
(ungrab-spy-bus) ;Let the net run again 

f irst-time-oniy 

(uai t-for-strobe-to-clear t) ;uait for valid coamand to disappear 

uai t 

(setq p-port 0) 

(uai t-for-strobe-to-set t) jwalt for a command 

(setq cmnd (idb tfolUdS p-port)) 

(if (< cmnd B) (setq addr (dpb p-port <^oe314 addr))) 

(grab-spy-bus false) :Don*t read net pkts in place of spy data 

(select cmnd ;di5patch 

;; Read tbus location 

O (setf (address remote-console-lbus-map-slot) ( I bus-address-page addr)) 
(setq cmnd (<-slong (aref remote-console- I buo-data-page 

(tbus-address-offset addr)))) 
(setq resp (fog tor (bus-read-response 

(Ish (Idb #00084 (ecc+hlgh remote-console-lbus-map-slot) ) 2) 
(Idb- typed word #o2602 cmnd))) ; top 2 bits 
(setq p-port resp) 
(setq p-port (Iogior resp 1_15.)) 
(uai t-for-strobe-to-clear) 

;; Strobe nou clear. Send middle 15 bits of result 
(setq p-port 0) 
(uai t-for-strobe-to-set) 
(setq resp (Idb-typed word <^ol717 cmnd)) 
(setq p-port resp) 
(setq p-port (Iogior resp 1_15.)) 
(uai t-for-strobe-to-clear) 
;; Nou send last IS bits 
(setq p-port 0) 
(uai t-for-stro^e-to-set) 
(setq resp (Idb-typed uord #00017 cmnd)) 
(go resp) ) 
;; Set high 12 bits of addr 
(5 (setq addr (dpb (long p-port) #ol414 addr)) 

(go return-normal -response) ) 
;; Byte read 
(1 (setq data (word (aref memory-as-bytes addr))) 

(setq resp (Iogior (Idb #o0010 data) normal-responce-ui th-data)) 
(go resp) ) 
;; Ulord read. Return low byte. 
(2 (setq data (aref memory-as-words (Ish addr -1))) 

(setq resp (Iogior (Idb #o0010 data) normat-response-wi th-data) ) 
(go resp) ) 
; ; Byte ur i te. 

(3 (setf (aref memory-as-bytes addr) (byte data)) 
(go return-normal -response) ) 
Uord urite " ~ ~"" 

(4 (setf (aref memory-as-words (ish addr -1)) data) 

(go return-normal -response) ) 
;t Extended commands 
(S (select (Idb #ol004 p-port) 
;: Reset 
(0 (funcatl (coerce address (make-pointer long-ptr UoU. U 47ie0_16. 471B5)))) 

(go return-normal -response)) 
;; Return lou byte of the data uord 
(1 (setq resp (Iogior norma I -response-ui th-data (Idb #00010 data))) 

(go resp)) 
;; Return high byte of the data word 
(2 (setq resp (Iogior norma I -response-ui th-data (Idb #ol010 data))) 

(go resp)) 
;; Set lou byte of the data uord 
(3 (setq data (dpb p-port #00010 data)) 

(go return-normal -response)) 
;; Set high byte of the data uord 
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(4 (setq data (dpb p-popt #ol010 data)) 

(go retupn-noriaa i -response) ) 
;; Escape to the stream-oriented protocol 
(5 (eetq resp jump-response) 
(setq p-port resp) 
(setq p-port (logiop resp 1_15,)) 
(ual t-for-strobe-to-c!ear) 
(setq p-port 9) 

(second- 1 eve 1 -para I I e 1 -port-protoco I ) 
(go uai t)} 
(otherwi se 
(setq resp command-errop-response) 
(go resp) ) ) ) 
; ; erpor 

(7 (setq resp cotnmand-epror-pesponse) 
(go pesp) ) ) 
retupn-nopwa I -response 

(setq pesp normal-pesponse) 
(go pesp))) 



Second level command processor 

He! pep macpo to genepate the select form fpom the cosimon definition of the 
consoie-program/fep commands 
(def I i Ir-acro generate-di spatch-table {) 
* (ppogn *compi le 

(def const «main-command-di spatch-table- length* word 

, (length *f cn-to-opcode-mappings«) ) 
(defconst «main-command-dispatch-tabte« command-dispatch-table 
(constant command-di spatch-table 

♦•(loop fop (index name) in «fcn-to-opcode-mappings* 

collect '(constant command-dispatch-table-entry 
cmd-code , index 
cmd-fcn (function .name))))))) 

(generate-dispatch-table) -use macro to generate the table 

(defun second- level -para I lel-port-protoco I 
(prog (((disp word))) 

(setq «pp-abort-f lag* false) 

(uai t-for-strobe- to-set) 

(setq «checKsum* ^oB5555? 

(setq disp (read-pp-word)) 

(if *pp-abort-f lag* (return)) 

(loop for (t word) below *main-command-di spatch-table- length* 

for (this word) « (cmd-code iaref «main-command-di spatch-table* t)} 
do ; (format t "^XI - ^, this - -0** i this) 
(when (- disp this) 

(funcall (cmd-fcn (aref «main-command-di spatch-table* i))) 
(return) ) 

f inal l y (process- cmd- error disp)))) 

(defun (check-checksum boots) 
(let ((check «checK.sum*) 

((low word) fread-pp-byte))) 
(and (not *pp-abort-f lag*) 

(wai t-for-strobe-to-set) 
(if (bit-test 1_14. p-port) 

(not (setq *pp-abor t-f lag* true)) 
(setq !ou (dpb p-port tfolBlQ (qu}> 
(cond ( (■ low check) 

(setq p-port 1_12, ) 
(setq p-port 11_12.) 
(wai t-for-strobe-to-clear) 
(setq p-port 0) 
true) 

(t (setq p-port (+ 7_12. 2)) 
(setq p-port (+ 17.12. 2)) 
(wai t-for-strobe-to-c lear) 
(setq p-port 8) 
false)))))) 

(defun process-goto 

(let ((addr (read-pp-addr) )) 
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(if (check-checttsum) (funca! i addr)))) 

(defun process-cmd-error ((code word)) 

(format t "^t? Error in fep command. Unknoun packet code *^." code) 

;; Nou return a pkt with opcode 1 « error. 

(uai t-for-stroDe-to-set) 

Csetq p-port (+ 7_12. 1)) lerror 1 

(setq p-port (+ 17^12. D) 

(ual t-fcr-strobe-to-cl ear) 

(setq p-port 0) ) 

(defrcom process-read-version 

(uri te-pp-word 1) ; first word — if prom, 1 if ram 

(wr i te-pp-long version-number)) ; second ■« version number 

(defwcom prccess-wr i te-bytes ((nbytes addr) (address addr)) 
(loop for (addr long) from address below (+ address nbytes) 

do (setf (aref memcry-ae-bytes #-bdlc (logxor addr 1) U+bd\c addr) 
(read-pp-byte) ))) 

(defrcom process-read-bytes ((nbytes addr) (address addr)) 
(loop for (addr tong) from address below (+ address nbytes) 

do (wr i te-pp-byte (aref memory-as-bytes ^•'td\c (togxor addr 1) )!f+bdlc addr)))) 

(defi^com process-wr i te-words ( (nwords addr) (address addr)) 

(loop for (addr long) from (ishr address 1) below (+ (Ishr address 1) nwords) 
do (setf (aref memory-as-words addr) (read-pp-word) ) ) ) 

(defrcom process-read-words ((nwords ad^r^ (address addr)) 

(loop for (addr long) from ( ( shr address 1) below (+ (Ishr address 1) nwords) 
do (wr i te-pp-word (aref memory-as-words addr)))) 
;;; Two special purpose routines for doing reads/writes to the I bus as fast as possible. 
;;; N.B. These routines require that an even number of Lbus words be read/written, 
(defwcom process-wr i te-tbus-block ( (nwds addr) (address addr)) 
(loop with (tb byte) with (tl long) 

for (addr long) from address below (+ address nwds) by 2 

do (setq (address Caref i bus-map Ibus-map-slot) ) (word ( I bus-address-page addr))) 
(setq tl (read-pp-fong)) 
(setq tb (read-pp-byte)) 

(setq (ecc+high (aref Ibus-map (bus-map-slot)) (Idb )?o0004 tb) ) 
(setf (aref (aref Ibus-data Ibus-map-slot) (Ibus-address-of fset addr)) 
(->siong tl)) 

(setq (address (aref Ibus-map Ibus-map-slot)) (word (I bus-address-page (!•»• addr) ) ) ) 
(setf tl (read-pp-tong) ) 
(setq tl (rot! tl 4)) 

(setf (ecc+hfgh (aref Ibus-map Ibus-map-slot)) (word (Idb #00004 t!))) 
(setf (aref (aref Ibus-data Ibus-map-slot) ( Ibus-address-of fset (1+addr))) 
(->8lcng (dpb (Ishr tb 4) #00004 tl))))) 

(defrcom process-read- 1 bus-block ((nwds addr) (address addr)) 
; (format t "-SProcess read I mem, addr - -wQ," address) 
(loop with (tb byte) with (tl long) 

for (addr long) from address below {+ address nwds) by 2 

do (setq (address (aref Ibus-map tbus-map-slot) ) (word ( I bus-address-page addr))) 
(wri te-pp-long (<-8iong (aref (aref Ibus-data ibus-map-slot) 

(Ibus-address-of fset addr)))) 
(setq tb (byte (ecc-fhigh (aref Ibus-map Ibus-map-slot)))) 

(setq (address (aref tbus-map Ibus-map-slot)) (word ( t bus-address-page (!•»- addr) ) ) ) 
(setq tl (<-8long (aref (aref Ibus-data Ibus-map-slot) 

(Ibus-address-of fset (1+ addr))))) 
(wri te-pp-byte (dpb (byte tl) #00404 tb) ) 

(setq tl (dpb (ecc+high (aref (bus-map Ibus-map-slot)) #o0C04 tl)) 
(setq tl (rotr tl 4)) 
(wri te-pp-long 1 1 ) ) ) 

;;; These two routines transfer blocks of fixnums between the Ln2 and the lbus. 
;;; They are used by the kludge Chaos kludge. 
(defwcom process-wr i te-f ixnums ((nwds addr) (address addr)) 
(let ((end (+ nwds address))) 
; (format t "**Nwds « ^c. Address • ^-o. Check » ^o** nwds address «chccksum*) 
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<loop with (addr long) ■ address 
uhi le (< addr end) 
for (uds-this-whack long) - (- (min end 

(1+ (logiop addr Ibus-address-cf fset-wask) ) ) 

for (page word) « (word ( tbus-address-page addr)) 

for (off long) • { tbus-address-of f set addr) 

for (bsase long) ■ (+ (coerce long (wake-pointer Ibus-data-page-ptr 

(aref I bus-data Ibus-map-siot) )) 
(Ish off 2)) 
do (setq (address (aref tbus-map tbus-wap-slot) ) page) 

(setq (ecc+high (aref Ibus-map Ibus-map-slot) ) 1) ;dtp-frxnura 

(loop for (1 long] from bbase belou (•♦• bbase (Ish uds-this-whack 2)) by 2 

do {self •(coerce word-ptr i) (rcad-pp-word) ) ) 
(incf addr wds-this-uhack) ) ) ) 

(defrcom process-read-f i xnums ( (nwds addr) (address addr)) 
(let* ((end (+ nwds address))) 
(loop with (addr long) ■ address 
whi te (< addr end) 
for (wds-this-whack long) - (- (min end 

(1+ (logicr addr Ibus-address-offcet-nask)) ) 
addr) 
for (page word) - (word ( Ibus-address-page addr)) 
for (off long) - ( Ibus-address-of fset addr) 
for (bbase I ong) - (+ (coerce 1 ong (make-po i nter I bus-da ta-page-ptr 

(aref Ibus-data Ibus-map-slot))) 
(ish off 2)) 
do (setq (address (aref Ibus-map Ibus-map-slot)) page) 

(loop foj^ (i longjfrom bbase below U bba se (I sh uds-thi s-whack 2)) by 2 
do (wri te-pp-word •(coerce word-ptr i))) 
(incf addr wds-this-whack)))) 
(defwcom process-ur i te-Ibus ((address long}} 
(let (((val Ibus-word))) 

(setf (data vai) (read-pp-long)) 
(setf (ecc+high vai) (read-pp-byte) ) 
<write-lbu5 address val))) 

(defrcom process-read- 1 bus ((address long)) 
(let ((val (read-tbus address))*) 
(wr i te-pp-long (data vai)) 
(ur ] te-pp-byte (byte (ecc+high val))))) 

(defwcom process-wr i te-tbus-and-ecc ((address long)) 
(let (((val Ibus-word))) 

(setf (data vai) (read-pp-long)) 
(setf (ecc+hrgh vat) (read-pp-word) ) 
(wr i te-lbus-and-ecc address val))) 

(defrcom process-read- I bus-and-ecc ((address long)) 
(let ((vat (read- I bus-and-ecc address))) 

(wri te-pp-long (data val) ) 

(wri te-pp-word (ecc+high va I ) ) ) ) 

; (defwcom process-wr ite-cmem-ucTT) 

; (loop for (i word) be tow (array- length spy-cmem) 

; do (setf (aref spy-cmem i) (read-pp-byte)))) 

(defwcom process-wr i te-cmem ((count word) (addr word)) 
(di sturb-uir) 

; (spy-writelS spy-sq-ctl (build sq-ctf enabfe-sq 1 step 9)) tpreset step off. 
(loop with (uwd microinstruction) 

with (adr microinstruction) - (build microinstruction cpc naf) 
for (ua word) from addr below (+ addr count) 

do ;; This loop assumes that the parity bit is CLEAR on the incoming instruction 
(loop with (parity byte) - 8 

for (i word) below (array-length uwd) 
for (next byte) - (read-pp-byte) 
do (setf (aref uwd i) next) 

(setq parity (logxor parity next)) 
finally (setq parity (logxor parity (Ish parity -A)) 
parity (logxor parity (Ish parity -2)) 
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parity (logxor parity (I sh parity -1))) 
(if (not (bit-test parity D) 

(alter microinstruction uud parity 1))) 
(alter microinstruction adr naf ua) 
(setf spy-cmem adr) ;address cmem 

(spy-writel6 spy-sq-cti (build sq-cti enab!e-sq 1 step 1)) ; (step-machine Muir)) 
(setf spy-cmem uwd) 

(spy-writelS spy-sq-ctI (build sq-cti enabte-sq 1 step cmem-write 1)) 
(spy-writelG spy-sq-ctI (build sq-ctl enable-sq 1 step cmem-write 2)))) 

(defucom process-wr i te-cmem-and-par i ty ((count word) (addr word)) 
(icop with _(uwd microinstruction) 

for (ua word) from addr below (+ addr count) 
do (loop for (i word) below (array- length uwd) 
do (setf (aref uwd i) (read-pp-byte))) 
(wr i te-cmcm-and-par i ty ua uwd))) 

(dcfrcom process-read-cmem ((count word) (addr word)) 
(loop with (uwd microinstruction) 

for (ua word) from addr below (+ addr count) 
do (read-cmem ua uwd) 

(loop for (i word) below (array- length uwd) 
do (wr i te-pp-byte (aref uwd i))))) 

(defwcom process-uri te-amew {(count word) (address word)) 
(loop with (val Ibus-word) 

for (addr word) from address below (+ address count) 
do (setf (data va!) (read-pp-long) ) 
(setf (ecc+high val) (read-pp-byte)) 
(write-amem addr val))) 

(defrcom process-read-amem ((count wordJ (address word)) 
(loop for (addr word) from address below (+ a^dre^s count) 
for (vat Ibus-Mord) « (read-amem addr) 
do (wr i te-pp-iong (data val)) 

(wr i tc-pp-byte (logand tfol7 (ecc+high val))))) 

(defrcom process-read-amem-and-par i ty ((count word) (address word)) 
(loop for (addr word) from address below (+ address count) 
for (val Ibus-word) • (read-amem-and-par i ty addr) 
do (wr i te-pp-long (data val)) 

(wri te-pp-byte (logand ;S?o377 (ecc+high val))))) 

(defwcom process-wr i te-bmem ((count word) (address word)) 
(loop with (val Ibus-word) 

for (addr word) from address below (+ address count) 
do (setf (data val) (read-pp-long)) 
(setf (ecc+high val) (read-pp-byte)) 
(wri te-bmem addr val))) 

(defrcom prccess-read-bmem ((count word) (address word)) 

(loop for (addr word) from address below (+ address count) 
for (val Ibus-word) - (read-bmem addr) 
do (wri te-pp-long (data val)) 

(wri te-pp-byte (logand ffol7 (ecc+high val))))) 

(defrcom process-read-bmem-and-pari ty ((count word) (address word)) 
(loop for (addr word) from address below (+ address count) 
for (val Ibus-word) » (read-bmem-and-par i ty addr) 
do (wr I te-pp-!ong (data vafl) 

(wri te-pp-byte (logand #o377 (ecc+high vai))))) 

(defucom process-wr i te-type-map ((count word) (address word)) 
(loop for (addr word) from address below (+ address count) 
do (wri te- type-map addr (read-pp-byte)))) 

(defwcom process-wr i te-type-map-and-pari ty ((count word) (address word)) 
(loop for (addr word) from address below (+ address count) 
do (wri te-type-map-and-parity addr (read-pp-byte)))) 
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(defrcom process-read-type-map ((count word) (address word)) 
(loop for (addr word) from address below (+ address count) 
do (ur ite-pp-byte (byte (read-type-map addr))))) 

(defucom process-wr f te-gc-map ((count word) (address word)) 
(loop for (addr word) frcisi address befow (-«- address count) 
do (wr i te-gc-map addr (read-pp-byte) ) ) ) 

(defwcom process-wr i te-gc-map-and-par i ty ((count word) (address word)) 
(loop for (addr word) from address below (+ address count) 
do (wr i te-gc-map-and-par i ty addr (read-pp-byte)))) 

(defrcom process-read-gc-map ((count word) (address word)) 
(loop for (addr word) from address below (+ address count) 
do (wr ite-pp-byte (byte (read-gc-»ap addr))))) 

(defwcom process-wri te-byte-r (wr i te-byte-r (read-pp-byte))) 
(defrcom process-read-byte-r (wr i te-pp-byte (byte (read-byte-r) ) ) ) 

(defwcom process-wri te-byte-s (write-by te-e (read-pp-byte))) 
(defrcom process-read-byte-s () (wri te-pp-byte (byte (read-by te-s) )) ) 

(defwcom process-wri te-stack-pointer (wr i te-stack-pointer (read-pp-long) ) ) 
(defrcom process-read-stack-pointer (wr i te-pp-long (read-stack-pointer))) 

(defwcom process-wr i te-frame-pointer (wr i te-frame-pointer (read-pp-Iong) ) ) 
(defrcom process-read-frame-pointer (wri te-pp-long (read-fra»ie-pointer) ) ) 

(defwcom process-wri te-xbas (write-xbas (read-pp-Iong))) 
(defrcom pr ocess-read-xbas (wr i te-pp-long Iread-xbas) ) ) 
(defrcom process-read-uir () 

(let ((val (if (and *read-state« «uir-saved*) «saved-uir« spy-cmem))) 
(loop for (i word) be^ou (array-Sength. spy-cmem) 
do (wri te-pp-byte (aref val i)})i) 

(defwcom process-wr 1 te-uir 
(loop with (wd microinstruction) 

for (( word) below (array- length wd) 
do (setf (aref wd t) (read-pp-byte)) 
finally (write-uir wd) ) 
(if «save-state* (setq *uir-saved* false))) 

(defwcom process-wr i te-cpc 
(let (ival (read-pp-long))) 
(wri te-cpc val) 
(if (and «save-state* «sequencer-caved*) (setq *saved-cpc* val)))) 

(defrcom process-read-cpc 

(wri te-pp-long (if (and *read-state« «sequencer-saved«) «saved-cpc« (read-cpc) ) ) ) 

(defwcom process-wr i te-npc 
(let ((val (read-pp-long))) 
(wri te-npc val) 
(if (and *save-state« «sequencer-saved«) (setq «saved-npc« val)))) 

(defrcom process-read-npc 

(wri te-pp-long (if (and »read-8tate« »sequencer-saved*) »saved-npc* (read-npc) ) ) ) 

(defwcom process-wr i te-csp 
(let ((val (read-pp-long))) 
(wri te-csp val ) 
(if (and *save-state» «sequencer-6aved«) (setq «saved-csp* val)))) 

(defrcom process-read-csp 

(wri te-pp-long (if (and «read-state« «sequencer-saved«) «saved-csp» (read-csp) ) ) ) 

(defrcom process-read-ctos 

(wri te-pp-long (if (and «read-state* *sequencer-saved*) «saved-ctos« (read-ctos) ) ) ) 

(defrcom process-read-opc ((loc word)) (wr i te-pp-word (word (read-opc loc)))) 
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(defrcom process-read-obus 

(iet ((val (if (and «read-5tate« *uir-»aved*} »saved-obus* (read-obus)) )) 
(wri te-pp-long (datavalH 
(up ite-pp-byte (iogand tfoU (ecc+high val)))}) 

(defucoffl ppocess-wri te-ffld 
(let (((val I bus-word))} 

(setf (datavai) (read-pp-jong) ) 

(setf (ecc+high vail (r€ad-pp-uorti> ) 

iur i te-md val) ) 
(if «savc-state« (setq *io-«d-saved« false))) 

(defrccm ppocess-read-md 

(let ((val (if (and *read-8tate« »io-md-8aved«) «saved-io-«d« (read-md)))) 
(urt te-pp-long (data val)) 
(write-pp-byte (Iogand A^cl? (ecc+high val))))} 

(defwcom process-uri te-pc (wrlte-pc (read-pp-long) ) ) 
(defrcom ppocess-read-pc (upj te-pp-long (read-pc))) 

(defucom process-upi te-vma 
(wpite-vma (pcad-pp-long)) 
(if *5ave-state« (setq *vma-Baved* false))) 

(defpcon ppocess-read-vna 

(up i te-pp-long (if (and *pead-state« *v(Ba-saved*) *saved-vina« (pead-vma) ) )} 

(defpcom process-read-asn {) (up i te-pp- long (pead-asn) ) ) 

(defpcoBi ppocess-pead-crocks ( (addp long)) (up i te-pp-long (pead-crocks addp) ) ) 

(defpco« ppocess-pcad-lbus-boapd-id Aboard byte) (loc bgte)) 
(up i tc-pp-byte (pead-lbus-boapd-\cf board ioc))i 

(defrcom process-pead-fep-boapd-id ((loc byte)) 
(upi te-pp-byte (apef fep-boapd- id-prom loc))) 

(defPcom ppocess-read-fep-paddle-id ((loc byte)) 
(up i te-pp-byte (aref fep-paddle- id-prom loc))) 

(defucom ppocess-upi te-cstk ( (addp uopd) ) (up ite-cstk addp (pead-pp-uopd) ) ) 
(defucoffl ppocess-wpi te-cstk-and-papi ty ( (addr uopd) ) 
(up i te-cstk-and-papi ty addp (pead-pp-uopd) ) ) 

(defPcom process-read-cstk ( (addr^ word) ) (upi te-pp- long (pcad-cstk-and-par i ty addr))) 

(defucom process-s tep-machine T(ntTmeV uordj ) (single-step-machine ntimes)) 

(defucom ppocess-stapt-»achine (stapt^tiachine) ) 

(dcfuccm process-stop-machine (stop-machine)) 

(defucom ppocess-pestope-state (pestope-state) ) 

(defucom ppocess-di scapd-state (di scapd-state) ) 

(defucom ppocess-upite-cup-task (wpite-task (pcad-pp-uopd))) 

(defpcom ppocess-pead-cup-task (up i te-pp-wopd (uopd (pcad-task) ) ) ) ' 

(defucom process-peset-lbus (peset-lbus) ) 
(defu com ppocess-peset- 36gg (resct-3688) ) 
(def I i Imacpo make-communication-var-tabtes 

(loop fop (vap type) in «console-communicat ton-vapiabics* 
collect • (type-size .type) into sizes 
collect '(function ,vap) into pointers 
finally (retupn * (progn *compile 

(defvap comm-vap-sizcs *byte-appay (constant *byte-appay .tsizcs)) 
(defvap comm-vap-addpcss *addpess-appay 
(constant «addpes3-appay ,«pointePs) ) ) )) ) 

(make-commun i cat t on-vap- tab \ e») 



(defucom process-urite-comm-var ( (var uord) (val long)) 
(let ((addr (aref comm-var-address vap))) 
(select (aref comm-var-sizes var) 

(1 (setf •(coerce byte-ptr addr) (byte val))) 
(2 (setf •(coerce uord-ptr addr) (uord val))} 
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(othcruiae (setf •(coerce long-ptr addr) val))))) 

(defpcoa pcocess-read-comm-var ((van word)) 
(let» ((addr (aref comm-var-address var)) 

(val (select (aref comm-var-sizes van) 

(1 (long •(coerce byte-ptr addr))) 
(2 (long •(coerce uord-ptr addr))) 
(otheruise •(coerce (ong-ptr addr))))) 
; (format t "^XRead var >^ at -0." var (long addr)) 

( ur i t e - p p-lon g val ) ) ) 

;;; Support for the Kludge 
(def ine-sysdfl-atommacros 
(fep-communicat ion-area 
k I udge- i npu t-char ac t er 
kludge-output-character 
k 1 udge-m i n i -buf f er-number 
kludge-Biini-buffer-ful D) 
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NIL or character that has been typed 

NIL or character to be typed out 

Next buffer to be filled (1 or 2) 

NIL if empty* else number of valid elements 



•e.24.) 

•1.24.) 

'2„24.) 

•3.24.) 

•4.24.) 

•5.24.) 

•6.24,) 

•7.24.) 

•10.24.) 

•11.24.) 

•12.24.) 

•208.24.) 

•201 24.) 

•202.24.) 

•203.24.) 

•204.24.) 

•205.24.) 



(defatowmacro *kludge-op-draw-char« 

(defatownacro «k ludge-op-set-cursorpos* 

(defatowmacro »kludge-op-clear-eol« 

(defatomaacro *kludge-op-c)ear-eof* 

(de f ato«wacro «k t udge-op-d i sp / ay- 1 osenged-s tr i ng« 

(de f a to««acr o »k 1 udge-op- i osenged-char* 

(defatomaacro «kludge-op-open-asct i-f i le« 

(defatommacro *kludge-op-open-binary-f i ie» 

(defatomnacro «kludge-op-f i I ename-char* 

(def ato«macro «k I udge-op-open-probe« 

(defatommacro »k ludge-op-beep» 

(dcf atonaacro *k I udge-op- i nput-char* 

(de fa town aero *k I udge-op-set-s i ze* 

(def atoamacro *k I udge-op-b i nary- 1 nput-char* 

(defatowmacro *kludge-op-f i le-open-success« 

(defatoBimacro «k ludge-op-f i le-open-fai lure* 

(defatoowacro «kludge-op-f i le-eof* 

(defrcom process-kludge-status 

(wr i te-pp-bute ( i f (machine-stopped-p/ 1 03 ) 

(wri te-pp-byte (if (/isp-nui[ (read-lbus kludge-output-character) ) 1)) 
(ur ite-pp-uord (if {Msp-nuM (read- (bus kludge-input-character) ) 1 0)) 
(write-pp-uord (if (tisp-null (read-lbus kludge-mini-buf fer-full ) ) 480 0))) 

(defucom process-send-kludge-mint -bytes ((nbytes word)) 

(let (((addr long) (if (- (read-lbus- long kludge-mini -buffer-number) 1) 1038 1480))) 
(loop for (i long) from addr below (+ addr nbytes) 

for (char long) • (logand 377 (word (read-pp-byte) ) ) 
do (ur i te- I bus- long i (logior *k I udge-op- input-char* char))) 
(write- 1 bus- long k iudge-mini-buf fer-f uM nbytes))) 

(defucom process-send-kludge-mini-words ((nuords word)) 

(let (((addr long) (if (- (read- 1 bus- long kludge-mini -buffer-number) 1) 1000 1400))) 
(loop for (i long) from addr below (+ addr nwords) 

for (word long) » (logand 177777 (long (read-pp-uord) ) ) 
do (wri te- I bus- long i (logior «k I udge-op-b i nary- input-char* word) ) ) 
(wri te- I bus- long kludge-mini-buffer-full nuords))) 

(defucom process-send-k t udge-m tni -longs ((n longs word)) 

(let (((addr long) (if (. (read-lbus- long kludge-mint-buffer-number) 1) 1008 1488))) 
(loop for (i long) from addr below (+ addr n longs) 
for ( I ong I ong) • (read-pp- I ong) 
do (wr i te-lbus-!ong i long)) 
(uri te-lbus-long kludge-mini-buf fer-ful I niongs))) 

(defucom process-send-k I udge-char Unchara wordl) 
(loop repeat nchars 

for (char I ong) - (read-pp- I ong) 

do (loop until (lisp-null (read-lbus k I udge- input-character) ) ) 
(wri te- I bus- I ong kludge-input-character char))) 

:; Ihis should be hacked to batch stuff across 
; (defrcom process-k ludge-rece i ve-chars 
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(let (((nchara uord) (if (lisp-nuM (read-lbus kludge-output-character) ) 9 1))) 
(wr i te-pp-uord nchars) 

(loop repeat nchars 

do (uri te-pp-tong (read- Ibus- I ong kludge-output-character) ) 
(ur i te-!bus k ludge-output-character 

(constant Ibus-uord ecc+high data 28C37403C3) ) ) ) ) ;hapd coded NIL 

(defvar kludge-buffer (array long 100)) 

(def const quot e-ni 1 Ibu s- uord (co nstant Ibus-tjord ecc+high^ data 20011^0380)) 
;; This should be hacked to batch stuff across ~ 

<defrcom process-k)udge-receive*char8 {) 
(loop for (index word) betou 100 

for (ud Ibus-word) « <read-lbu8 kludge-output-character) 
unti I (I isp-nu) t ud) 

do (setf (aref kludge-buffer index) (data ud)) 
(write- 1 bus kludge-output-character quote-nil) 
(loop repeat 100.) ;Pause to refresh, 

finally (wr i te-pp-uord index) 

(loop for (i word) befow Index 
„, do ( urite-pp-tong (aref k ludge-buffer »))))) 

F:>LMach>Fep>fontgen.11sp,l 



;;: -»- Base: 8: ttode: LISP; Package: Li I; Base: 8; Lowercase: T -«- 

(deftype font (structure () 

(char-height word) 
(char-width word) 
(raster-height word) 
(raster-width word) 
(base I ine word) 
(bytes (array byte 0)) 

(def global name font) 

(defun output-font-to-l inker (font ^optional (psect "CODE")) 
(let* ((name (string (font-na»e font))) 
(rwidth (font-rastep-width font)) 
(rheight (font-raster-height font)) 
(rasters-per-word (font-rasters-per-word font)) 
(words-per-char (font-words-per-char font)) 
(bytes-per-raster (// (+ rwidth 7) 8)) 
(bytes-per-char (« bytes-per-raster rheight))) 

iModule-dectare nane psect) 
[symbol -dec tare name name) 
tset-origin name) 

; em it-word ( font-char-he tght font) *:none) 
lemit-word (font-char-width font) 'snone) 
tern it-word (font-raster-height font) *:none) 
temit-word (font-raster-width font) 'tnone) 
! em it-word (font-baseline font) 'znone) 

(loop for char below 200 

for c-off upfrom by (« words-per-char 32.) 
do (loop repeat words-per-char 

with bytes- 1 eft » bytes-per-char 

for u-off upfrom by 32. 

do (loop repeat rasters-per-word 

for r-off upfrom by rwidth 
for raster • (loop repeat rwidth 

for i upfrom (+ r-off w-off c-off) 
for she upfrom 
sum (ash (aref font i) she)) 
do (loop repeat (min bytes-per-raster bytes- left) 
for ppss upfrom J!^o0310 by ;S'ol000 
for byte « (Idb ppss raster) 
do (send irrnk:»linker* 

*: cm it-byte byte «bdtc*) 
(decf bytes-left))))))) 



inend 




nk:«l 


nker* * 


(send 




nk:«t 


nker* ' 


(send 




nk:»t 


nker* ' 


(send 




nk:»l 


nker* ' 


(send 




nk:»l 


inker* * 


(send 




nk:«l 


nker* ' 


(send 




nk:*l 


nker* ' 


(send 




nk:«l 


nker* ' 



4,887,235 
1007 1008 

(deftype sync-prograo Istructure C) 

{words-pep- I ine word) 
(video-f ieid-Mnes word) 
(n-uord9 uordl 
(sync (array word n-words))}) 

(defglobal narae sync-program) 

(defun output-sync-pPogram-tO"! inker (prog ^optional (psect "CODE")) 
(let* ((name (send prog *:name)} 

(arry (send prog *: make-program) ) ) 

(send I I ink:*I inker* * module-dec fare name psect) 

(send tnnk:«linker» ^tsymboF-declare name name) 

{send 11 ink:*l inker* '; set-origin name) 

(send I I ink:*l inker* ':e«tt-Mord (send prog ' :uords-per-I ine) 'tnone) 

(send 1 I ink: «l inker* 'tern it-word (send prog ': video-f ield- 1 ines) 'tncne) 

(send 1 i ink:*I inker* •:cmit-word (array-act ive- length apry) 'tnone) 

(loop for ud being the array-elements of arry 

do (send 1 1 ink; *l inker* * sewi t-uordud ^inone) ) ) ) 
F:>LMach>Fep>Display.in.l4 



;;; -*- Mode: LIL; Base: 8; Package: LIL; Lowercase: T -*- 

(include "Types-and-macros") 

(deftype window-stream-type (structure (include stream-type) 

(window window) ) ) 

(deftype window-stream (pointer wlndou-stream-type auto-dereference t)) 

(defglobal philips-display sync-program external t) 
(defglobal bigfnt font external t) 
(defglobal cptfont font external t) 
(defglobal tvfont font external t) 
(defvar «font* font-ptr) 

(defvar *di splay-words-per-l ine* word) 
(defvar «di splay-width* word) 
(defvar «dr splay-height* word) 
(defvar «di splay-data-start* long) ^ 

(defvar «standard-output-8treaffl« stream) 
; (defvar *standard-output-window* window) 
(defvar «whole- screen- window* window) 

(deflil»acro wri te-di splay (off ud) 

Mur ite-iob-reg (+ (long ,off) «d(sptay-memory-of f set*) ,wd)) 
(defi i l»acro read-display (off) 

Mread-iob-reg (+ (long .off) *dtspIay-nemory-of f set*) ) ) 

(deflil»acro write-sync (off wd) 

* (wri te-iob-reg (+ (long ,off) *sync-memory-of fset*) ,wd)) 
(deflilaacro read-sync (off) 

Mread-iob-reg (+ (long ,off) *sync-inemory-of fset*) ) ) 
(defun init-di splay 

(setq *font* (make-pointer font-ptr cptfont)) 
(di splay-setup-moni tor phi I ips-disptay) 
(set-fields «whole-screen-wJndow« 

cursor-x cursor-y 

x-offset y-offset 

height «di sp lay-height* width »di splay-width* 

vsp 1) 
(setq *st3ndard-output-stream* (allocate-stream (type-size window-stream-type))) 
(set-fieids *9t3ndard-output-stream* 

x-pos y-pos 

for-tyo #'window-stream-tyo 

for- terpri-or-fresh- line <?'window-strea«-terpr i-or-fresh-1 ine 
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(set-fields (uindou (coerce uindow-stream «standard-output-8treaffl*) ) 

cursor-K 8 cursor-y 9 

x-offset y-offset (// *di8p lay-height* 2) 

uidth »dispiay-uidth« height (// «di splay-height* 2) 

vsp 1) 
(d i tp I ay-c 1 ear-w i ndow «who I e-screcn-u i ndou«) 
(setq standard-output «8tandard-output-streaa«) 
(fomat t "-AFep^s up! •) 
) 

(defun dispiay-setup-Boni tor (Cprogran sync-program)) 
; (f ind-io-t!oard-base) 
(stop-display) 

(setq «display-words-per-l ine* (words-per-1 ine program) ) 
(setq *display-uidth» (ashi »disptay-uords-per-l tnc« 5) ) 
(setq «d»splay-height* (video-field-lines program)) 
(setq »display-data-start« (+ «di splay-data-offset* «di8play-Bemory-of fset* 

ttiob-board-base*) ) 
(d i sp I ay- 1 oad-sync-program program) 
(start-display) 
(di splay- load- I ine-po inters program)) 

(defun di splay- load- I ine-po inters ((program sync-program)) 
(let ((wcrds-per-I ine (words-per-l ine program)) 
dines (video-f ietd-t ines program))) 
(loop for (Itne-ptr uord) betou (Ishl lines 1) 

do (ur ite-display I ine-ptr 8)) 
(loop for (1 ine-ptr word) belou (Isht lines 1) by 2 

for (i ine-address long) from *d»8play-data-of f set* by words-per-I ine 

do (write-di splay I ine-ptr (ashr line-address 1))))) ;I don't understand this 

(defun di splay- toad-sync-program ((program sync-program)) 
(loop for (i word) below (n-words program) 

do (write-sync i (aref (sync program) i)))) 

(defun main treat ly display-test 
(declare (require asm-hack)) 
(dispiay-setup-moni tor phi I ips-di splay) 
(display-hoTie-up bigfnt) 
(loop for (off uord) upfrom 8 

do (loop for (i uord) from #/a to <f/2 
do (draw-character i bigfnt) 
(draw-character i cptfont) 
(draw-character i tvfont)) 
(display-ncwi ine bigfnt)J)_^_ _ 
:: Higher level display hacking 
(defun start-disptay () 

(wr i te-iob-reg *vd-8tatus-of f set* (build vd-status vseq-enable 1 vseq-run 1))) 

(defun stop-display 

(write- ioD-reg *vd-status-of fset* 

(change vd-status (read- iob-reg *vd-status-of f set*) 
vseq-e nafate vseq-run 0))) 

Idefun draw-character ((char word) (font font) (how tv-fcn) (window window)) 
(let* ((r-width (raster-width font)) 
(baseline (baseline font)) 
(bytes-per-raster (// (+ r-width 7) 8)) 

(bytes-per-char (» bytes-per-raster (raster-height font))) 
;; Pre-calculate the indexes into the font's byte array 
(char-start (« bytes-per-char char)) 
(char-end (+ char-start bytes-per-char))) 

(setq (cursor-y window) (max (curaor-y window) baseline)) 

(if (> (+• (char-width font) (cursor-x window)) (width window)) 
(di splay-new I ine window font)) 

;: Ue go through this loop once for each raster line. 

(loop with (x word) • (+ (x-offset uindou) (cursor-x window)) 

for (offset uord) from char-start belou char-end by bytes-per-raster 
for (y uord) upfrom (+ (y-offset uindou) (- (cursor-y uindou) baseline)) 
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for (raster (ong) - 

do ;; Through this loop once for each byte in a raster line, 
(loop for (she byte) below (byte r-width) by 8 
for (i word) upfrom offset 
do (setq raster 

(logior raster 

(Isht (long (Idb ;;ro8010 (word (aref (bytes font) i)))) 
shc> ) ) ) 
;; Through this loop once for each 32 bit word read from the L8US. 
(loop for (bits-ieft byte) - (byte r-width) then (- bits-left s) 
until (zerop bits-left) 

for (word long) upfrom (+ C« y sdisplay-words-per-I ine*) 

«display-data-start» 
(Ish X -5.)) 
for (i long) « (I bus-address-offset word) ; pointer into Ibus nap 
for (p byte) • (Idb ^o8035 (byte x)) then 
for (8 byte) - (min (- 32. p) bits-left) 
for (mask long) - (ash! (-1- (ashi 1 s)) p) 
dp (setf (address (aref tbus-nap Ibus-nap-slot) ) 
(word (I bus-address-page word))) 
(setf (aref (aref Ibus-data Ibus-map-slot) i) 

(->8long (logior (logand mask (asht raster p) ) 
(logand (lognot mask) 
(<-8long 

iaref iaref Ibus-data Ibus-map-slot) 
i)))))) 
;; Account for the bits just output 
(setq raster (Ishr raster a)))) 
<incf (cursor-x window) (char-width font)))) 

(defun display-new I ine ( (window uindow) (font font)) 
(setq (cursor-x window) 0) 

(tncf (cursor-y window) (+ (char-height font) (vsp window))) 
(if (> (+ {- (char-height font) (baseline font)) (cursor-y window) ) (height window)) 

(display-home-up window font)) 
(di splay-clear- I ine window font)) 

(defun display-home-up ((window window) (font font)) 
(setq (cursor-x window) 0) 
(setq (cursor-y window) (baseline font))) 

(defun di splay-clear- I ine ( (window window) (font font)) 

(setq (cursor-y window) (max (cursor-y window) (baseline font))) 
(loop repeat (+ (char-fieight font) (vsp window)) 

for (y word) upfrom (- (cursor-y window) (baseline font)) 

do (display-draw-line 8 y (width window) y alu-setz window))) 

(defun display-clcar-window ((window window)) 
(loop for (y word) below (height window) 

do (display-dra w-i ine 9 y (width window) y alu-setz window))) 
(defun disp lay-draw- line ((x word) (y word) (to-x word) (to-y word) 

(how tv-fcn) (window window)) 
(if (- y to-y) 

(displsy-draw-hor izontal-l ine x to-x y how window) 
;: Someday 
)} 

(defun display-draw-horizontal-l ine ((x word) (to-x word) (y word) 

(how tv-fcn) (window window)) 

(setq X (+ (max x 0) (x-offset window))^ 

(setq to-x {+ (min to-x (width window)) (x-offset window))) 

(setq y (+ (max (min (height window) yj) (y-offset window))) 

:; First draw the portion in the first word 
(loop unti I iz X to-x) 

for (start word) - (Idb #00005 x) 

for (end word) « (min 32. (- to-x x) ) 

for (nbits word) « (- end start) 

for (mask long) - (ashI (1- (ashl (long 1) nbits)) start) 

for (address long) upfrom (+ (Ish x -5) 
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(long {« y *di spiay-uords-per-l ine*) ) 
»d i 8p I ay-data-star t*) 
for (data long) - (read- Ibus- long address) 
_ do (select hou 

(alu-setz (setq data (logand (lognot Mask) data))) 
(alu-xor (setq data ((ogxor mask data))) 
(alu-seta (setq data (logior aask data)))) 
(ur i te-l bus- long address data) 
(incf X nbits))) 



;;; Stream interface to the display (output side), 
(defun window-streaii-tyo ((stream stream) (char byte)) 

(draw-character char •♦font* alu-xor (window (coerce window-stream stream)))) 

(defun window-streax-tcrpri-or-fresh-Iine ((stream stream) (terpri boole)) 
(let {(ws (coerce window-stream stream))) 

(if (or (not (rerop (cursor-x (window ws)))) terpri) 
(d i splay-new I ine (window us) •*font*))>> 

F:>Tfflach>fep>Keyboard.in .16 ' 



;;;-«- node: Lil; Package:Lf/; BaserS.; Lowercase: T -«- 

;;; My first LIL program^ so don't laugh too hard. . .—HIC 

(include "Types-and-macros") 

(dcflilmacro def ine-mpsc-constants (4rest regs) 

(let ((package (pkg-f ind-package ^. (pkg-name package) )) ) 
* (prcgn 

.•(loop for (reg adr . data) in rcgs 

append (loop for (sym val) in data 

coHect • (defatomniacro ,(fintern "-.A-wA" reg sym) \val)) 
into code 

do (push ' (def atommacro ,(f intern "^A-REG" reg) \adr) code) 
finally (return code))))) 

(def ine-mpsc-constants 
! ; Ur i te regi sters 
(mpsc-cti 8 

(reset-ext-status-ints 20) 

(channel -reset 33) 

(error-reset G0) 

(end-of-int 78)) 
(mpsc-int 1 

(wai t-enable 288) 

(wai t-on-rx 48) 

(rxint-on-lst-or-spec 18> (rxint-on-ai {-or-spec-di f f-vec 20) 

(rxint-on-al l-or-spec-same-vec 38) 

(status-affects-vec 4) {Channel B only 

(txint-dma-enb 2) 

(ext-tnt-enb 1)) 
((rpsc-sys-conf ig 2 ;Channel A only 

(syndet-not-rts-b 288) 

(vectored 48) 

(pr icr i ty 4) 

(a-dna-b-int 1) (both-dma 2)) 
(mpsc-vector 2) ;Channei B only 

(mpsc-rcv 3 

(£-bits 8) (7-bits 188) (G-bits280) (8-bits388) 

(auto-enb 48) 

(hunt 28) 

(crc-eno 18) 

(addr-srch 4) 

(cync-load-inh 2) 

(enb D) 
(npsc-mcde 4 

(xl-clock 8) (xlG-clock 108) (x32-clock 288) (x64-ctock 380) 

(8-bit-«ync 8) 

(16-bit-Eync 28) (hd!c-sdl c-f lag 48) (ext-sync 68) 

(enb-sync 0) 
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(l-stop-bit A) (1.5-stop-bits 10) (2-stop-bits 14) 

(even-par 2) 

{par-enb 1) ) 
(rpsc-^nt 5 

(dtr 222) 

(5-bi tE-or-tess 8) 

{7-tits 48) 

(6-bits 183) 

(8-bits 140) 

(send-break 20) 

(enb IC) 

(crc-mode 4) 

(pts 2) 

(crc-enb 1) ) 
<mpsc-sync-or-adr E) 
<npsc-sync-or-f lag 7) 

;: Re2d registers 
(mpsc-status 

(break-abort 20C) 
' (tx-underrun 100) 

(cts 40) " 

(sync-hunt 20) 

(carrier-detect IB) 

(tx-empty 4) 

(int-pending 2) ;Channel A only 

(char-avai I D) 
(mpsc-rcv-cond 1 

(end-of-frame 200) 

(crc-framing-error 100) 

(rx-ovcrrun-error 40) 

(pari ty-error 20) ) 
) 

(deflilwacro mpsc-uri te-reg (mpsc peg val) 
' (progn 

(setf (control ,mpsc) ,peg) 
(setf (control .mpsc) , val ) )) 

(deflilmacro mpsc-read-reg (mpsc reg) 
• (progn 

(setf (control ,mpsc) »peg) 
(control ♦mpsc))) 

(defmacro pead-16-bi t-dma-reg (peg) 
•ilct (dou (logand 377 (uord ,peg))) 

(high (logand 377 (wopd ,peg)))) 
i logand tow ( I sh high 8) ) ) ) 

(defmacpo wr i te-lS-bi t-dma-peg (peg val) 
•(progn (setf ,peg (byte ,val)) 

(setf ,peg (byte ( I sh ,val -8))))) 
(defatommacpo kbd-dma-channel '0) 
(defatommacpo kbd-buf fcp-size 300) 
(deftupe kbd-buffep (pointep kbd-buf fep-arpay) ) 
(deftype kbd-buf fcp-appay (apray byte kbd-buf fep-size) ) 

(defvap kbd-buffep-appay-0 kbd-buf fep-appay) 
(defvar kbd-buf fer-apray-l kbd-buf fcp-appay) 

;;; These pointeps get swapped when ue suitch buffeps. 

(defvap cuppent-kbd-buffep-fop-f i ! I ing kbd-buf fep) 

(defvar cuppcnt-kbd-buf fep-fop-emptying kbd-buf fep) 

(defvap cuppcnt-kbd-buf fep-putter wopd) 

(defva p cuppent-kbd-buf fep-takep uord) 

(defun tni t-kcyboard 
(ini t-Bpscs) 

(setf (pcad-tempAmastep-cleap spy-dma-contro! lep) 0) ;mastep cleap DTtA contpollep 
(setf istatusAcommand spy-dBa-controllepJ (build fep-dma-command selection "Extended" 

dpcq -Active high" 
dack "Active low")) ;240 
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;;Inttiali2e the database for <BD dma 

Csetq fep-seriat-dma-and-clocK-cti (build fep-ccp-dma-control a-dma "pcv a")) 

(sctq current-kbd-buf fer-for-emptying (»ake-pointer kbd-buffer kbd-buf fer-array-0) ) 

<setq cuppent-kbd-buffer-for-f i I I ing («ake-pointep kbd-buffep kbd-buf fer-apray-1) ) 

(maybe-suap-kbd-buf fcps true) ; startup dma 

(setq current-kbd-buf fer-puttcr 0) ;init the pointers 

(setq current-kbd-buf fer-taker 8) ) ; so ue don't send a garbage buffer 

<riefun intt-ptpscs 

(wpsc-ini t-mpsc mpsc-0-a) 
(iwpsc-ini t-mpsc mpsc-l-a) 
(mpsc-ini t-chan-async B»psc-9-a) ) 

(defun «p5c-init-«psc ( (mpsc-chan-a mpsc iiode ref)) 

(mpsc-urite-reg mpsc-chan-a «psc-ct l-reg 38) ;Reset channel A 
(mpsc-ur ! te-reg «psc-chan-a inpsc-sys-conf ig-reg mpsc-sys-conf ig-a-dma-b-int) ) 

(defun wpsc-inl t-chan-async ((npsc tipsc mode ref)) 

(mpsc-uri te-reg mpsc mpsc-ctl-reg 30) ;ChanneI reset 

(ftipsc-MPi tc-peg mpsc mpsc-mode-reg (logiop mpsc-mode-xl-clock mpsc-mode-l-stop-bi t) ) 

(mpsc-upl te-reg mpsc mpsc-rcv-reg (logior mpsc-rcv-8-bi ts mpsc-rcv-enb) ) 

(mpsc-wrt te-reg mpsc mpsc-xmt-reg 

(logior mpsc-xwt-dtr mp»c-xmt-8-br ts mpsc-xmt-enb mpsc-xmt-rts) ) ) 

(defun mpsc-echo ((mpsc mpsc node ref)) 
(do () (false) 

(loop until (bit-test mpsc-status-char-avai I (control mpsc))) 
(let ((chap (data mpsc))) 

(fopmat t --^XChap - -vO" chap)))) 

(deftype p-byte (pointer byte)) 

(defun mpsc-echo ((mpsc mpsc mode pef)) 

(let ({ptp (rake-pointer p-byte (control mpsc)))) 
(do (false) 

(loop until (bit-test mpsc-status-char-avai I ©ptr)) 
(let ((char (data mpsc))) 
(format t -^XChar « ^" char))))) 

(def ine-eysdfl-atommacros 
(system-communi cat i on-area 
mouse-x 
mouse-y 
mouse-buttons 
iTiouse-wakeup 
kbd-buf fer-start 
Kbd-buf fer-end 
kbd-buffer-in-ptr 
kbd-buf fer-out-ptr) ) 

<def ine-sysconstant tXq-po inter) 

(defatcmmacro 3o00-fixnum 1) 

(dcfatommacro key-type-bp 0403) 

(defatomnacro type-mouse-switch 8) 
(defatommacro type-mouse-move 1) 
(defatommacro type-al l-keys-up 2) 
(defatommacro type-boot 3) ^ 
(defatommacro type-key-doun 4) 
(defatommacro type-key-up 5) 

(defun al ter-3S00-syscom ( (addr long) (delta Jong)) 
; (format t •*-*4Alter syscom •*0, S*0" addr delta) 
(let* (iud (read-ibus addr)) 
(val (data ud))) 
(setf vai (dpb (+ val delta) t:tq-po inter va!)) 
(setf (data ud) vai) 
(write- 1 bus addr wd))) 
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(defun key-to-3G0a ((key long)} 

(let* ((in-ptr (read-lbus kdd-buffer- tn-ptr) ) 

(in-ptp-pointer-oid (Idb 8034 (data in-ptr))) 
(in-ptr-pointer (1+ in-ptr-pointer-old) ) 
{out-ptr (read-lbus kbd-buf f er-out-ptp) ) 
(out-ptr-pointer (Idb 0334 (data out-ptr))) 
(start (read-lbus kbd-buf fer-star t) ) 
(start-pointer (Idb 0034 (data start))) 
(end (read-lbus kbd-buf fer-end) ) 
(end-pointer (idb 0034 (data end)))) 
(if (> in-ptr-pointer end-pointer) (setq in-ptr-pointer start-pointer))' 
; (format t "-^Key to 3B00 - -^ at -vQ- key tn-ptr-pointer) 
(if (- in-ptr-pointer out-ptr-pointer) (format t "^^ No room in buffer")) 
;; Should process wait here... 
(when (^ in-ptr-pointer out-ptr-pointer) 
;; Room in buffer, first store the character 
(write- 1 bus- long in-ptr-po inter-old key) 

;; Now increment the in pointer to point to the next free location 
(setf (data in-ptr) (long (dpb in-ptr-pointer 0034 (data in-ptr)))) 
(wri te-lbus kbd-buf fer-in-ptr in-ptr)))) 

;:; This is called from the idle loops of the loader program 
(defun Kbd-process-top-ievel (run-keyboard mpsc-0-a)) 

;;; Code to run keyboard for 3B00 
(defun run-keyboard ( (mpsc mpsc mode ref)) 
(prog (((char byte)) ) 
wai t-for-next-command 

(setq char (get-kbd-char) ) 
next-command 

(cond ((< char 0) 

;; A command byte, process it 
(select (Idb 0403 char) ;key-type-bp 

((type-ai l-keys-up type-key-down type-key-up) 

;; All of these read one more byte, then send data to L machine 
• (let ((next-char (get-kbd-char))) 

; (format t ", ^" (togand 377 (word next-char))) 
(if (> next-char 0) 

(key-to-3SC0 (logior (IshI (logand 377 (long char)) 8) 
(logsnd 377 (long next-char)))) 
(setq char next-char) 
(go next-command)))) 
(type-mouse-fflove 
(let ((y-motipn (Idb 0202 char)) 
(y-motion (Idb 0002 char))) 
(cond ( (- x-motion 1) 

(alter-3BC0-syscom uouse-x 1)) 
( (» x-motion 2) 
(al ter-3B00-syscom mouse-x -1))) 
(cond ( (• y-mot ion 1) 

(al ter-3G00-sy8Com mouse-y 1)) 
( (■ y-motion 2) 
(alter-3680-syscom mouse-y -1)))) 
(wr i te-lbus- long mouse-wakeup 0)) 
(type-mouse-switch 
;; Mouse buttons -- tell 3S30 
(let (deft-p (bit-test char 4)) 

(middfe-p (bit-test char 2)) 
(right-p (bit-test char 1))) 
(wr i te- Ibus-long mouse-buttons 

(logior (if left-p 1 0) 

(if middle-p 2 0) 
(if right-p 4 0))) 
(wr i te-Ibus-long mouse-wakeup 0))) 
(type-bffot 
(funcall (aref memory-as- longs 1)))))) 
(go wai t-for-next-command))) 

; (defun fget-char- from-mpsc byte) ((mpsc mpsc mode ref)) 
; ( Icop u\ th (char byte) 
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until (Console-char-avat lable-p (make-pointer wpsc-ptr Rpsc) ) 
do (pPoces9-wai t "Character frotn console" 

#• Conso / e-char-ava i tab Sc-p (make-pointer wpsc-ptr mpsc)) 
_ finallg (setq char (data mpsc)) 

; (format t "*^har - -^0" (logand 377 (word char))) 
(return char) ) ) 

; (defun (Console-char-avai lable-p boole) ((mpsc mpsc-ptr)) 

; (bit-test mpsc -status-char-av ai ( (c ontrol »gipsc))) _ _^ „ 

(defun (naybe-tuap-kbd-buf fers booie) ( («uap-even-t f-empty boote)) 
;;8et the mask bit to stop chan» and clear flop 

(setf (wr i te-s ingle-mask spy-dma-control ier) (+ 4 kbd-dma-channel)) 
(setf (clcar-f 1 tp-f iop spy-dma-control ler) jB) 

(let (((current-count Mord) (read-16-bi t-dma-reg (kbd-count spy-dma-control ler)))) 
(when (or (^ current-count kbd-buf fer-size) 
twap-even-i f-empty) 
! ;9wi tch buffers 

(swapf currcnt-kbd-buffer-for-f i 1 1 ing current-kbd-buf fer-for-emptying) 
(setq current-kbd-buf fer -putter (- Kbd-buf fer-size current-count)) 
(setq current-kbd-buf fer-taker 8) 
;; Now start dma on the next 
(let (((addr long) (coerce long current-kbd-buf fer-for-fi I I ing) ) ) 

;; Now write the addresses. Fep handles high address bits itself. 

(write-lB-bi t-dma-reg (kbd-address spy-d»a-control ler) addr) 

(setf (aref spy-dma-high-addrs kbd-dma-channel) (byte (Ish addr -IB.))) 

:; Now write the byte count, and mode - 104 

(write-lB-bi t-dma-reg (kbd-count spy-dma-control ler) kbd-buf fer-size) 

(setf (write-mode spy-dma-control ler) 

(build fep-dma-mode channel kbd-dna-channe t direction "Urite" node "Single")) 
5 ; clear errors, no interrupt enables, 
(setq fep-dma-control 9))) 
;; Re-enable the channel 

(setf (wri te-8 ingle-mask spy-dma-control ler) kbd-dma-channel)) 
;; Return buffer non-emptyness 
(* current-kbd-buf fer-putter current-kbd-buf fer-taker) ) 

(defun (kbd-char-avai labte boole) 

(or im current-kbd-buffer-putter current-kbd-buf fer-taker) 
(maybe-swap-kbd-buffers false)) ) 

;;; Gets 1 char. Process watts if none available, 
(defun (get-kbd-char byte) (> 
(loop until (kbd-char-avai I able) 

do (process-wait "Kbd in" ^* kbd-char-avai I able) 
finally (return (progl (aref •current-kbd-buf fer-for-emptying 

current-kbd-buf fer-taker) 

_ (incf current-kbd-buf fer-taker) ) ) ) ) 

::;-«- floderLISP; Package; USER; Baserld,; Lowercase: Yes -*- 



;;; Macros to access the various parts of the instruction definitions 
Idef struct (insn (:type : named-array) 
; cone-name) 

: const 

tirask 

:b-pat 

:t-pat) 

(defconst »binary-pattern-l ist« 

• (tpattern name size 

(^*" alterant 1) 

("ea" ea B) 

("dst-ea" dest-ea B) 

("rx" regx 3) 

(Vy; regy 3) 

( CO condition 4) 

("dir" direction 1) 

("sire" size-bwl 2) 

("move-sz" move-sz 2) 

("sz-wl" size-wl 1) 

("qdat" q-data 3) 

("bute" byte 8) 
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(•-nTb" 


nTbble 4) 


("bitop* 


bitop 2) 


(defconst «te 


xt-patterh-l ist« 


• i;pattern 


name 


dreg-x) 


i:k 


dreg-y) 


("Ax" 


areg-x) 


("Ay" 
C-lAx)- 


areg-yJ 
auto-decr-x) 


(".(Au)- 
("(Axf+'' 


auto-decr-y) 


auto-incr-x) 


C(Au)^." 
Cd(Ay)* 


auto-incr-y) 


i ndexed-d i sp t acement) 


("idata" 


immediate-data) 


(" iword" 


immedi ate-word) 


("qdata" 


quick-data) 


("baddr" 


branch-address) 


Cidisp" 


i«imediate-di sp) 


("dst-ea" 


dest inat ion-ea) 


("ccr" 


cc-regi ster) 


("sr" 


status-register) 


Cusp" 


user-stack-pointer) 


("qbyte" 


iioveq-byte) 


("vector" 


vector) 


("ea" 


ea) 


("eal" 


ea-uord))) 



(defconst «instruct ion-patterns* 
M("118e rx 10809 « ry" 
("1101 rx dir size ea" 
("1101 rx sz-ul 11 ea" 
("0000 0110 size ea" 
("0101 qdat size ea" 

; adda? ("1101 rx 1 size 00 « ry" 
("1100 rx dtr size ea" 
("00C0 0010 size ea" 
{"1110 qdat m size 00 ry" 
("1110 rx » size 1 00 ry" 
("8110 cc byte" 
("0030 rx 1 bitop ea" 
("0000 1000 bitop ea" 
("0110 0000 byte^ 
("0110 0001 byte" 
(-0100 rx 110 ea" 
("0100 0010 size ea" 
("1011 rx size ea" 
("1011 rx sz-wl 11 ea" 
("0000 1100 size ea" 
("1011 rx 1 size 001 ry" 
("0101 cc 11001 rx" 
("1000 rx « 11 ea" 
("1011 rx 1 size ea" 
("0000 1010 size ea" 
("1100 rx 1 0100 « ry" 
("1100 rx 1 10001 ry' 
("0100 100 01 sz-ul 000 rx" 
("0100 1119 11 ea" 
("0100 1110 10 ea- 
("0100 rx 111 ea" 
("0109 1110 0101 rx" 
("1110 qdat « size 01 rg" 
("1110 rx » size 1 01 ry" 
("00 move-sz dst-ea ea" 
("0100 0100 11 ea" 
'("0100 0110 11 ea- 
("0100 0000 11 ea" 
("0100 1110 0110 dir rx" 
; ("001 sz-ul rx 001 ea" 

("0180 1 dir 001 sz-ul ea" 
("0080 rx 1 dir sz-ul 001 ry" 
("0111 rx byte" 
("1100 Rx » II ea" 
("0100 1090 00 ea" 
("0100 0100 size ea" 
("0100 0000 size ea" 
("0180 1110 0111 0001" 
("0180 0110 size ea" 
("1000 rx dir size ea" 
("0009 0030 size ea" 
("018t) 1003 01 ea" 
("0100 1110 0111 0000" 
("1110 qdat * size 10 ry" 
("1110 rx » size 1 10 ry" 
("1110 qdat « size 11 ry" 
("1110 rx m size 1 11 ry" 
("0100 1110 0111 0011" 
("0100 1110 0111 0111" 
("0100 1110 0111 0101- 
("1800 rx 18808 « ry" 



;one of 0-t9t, 1-chg, 2«ctr, S-set 



;ttove instructions 



"abed Dy.Dx" "abed -(Ay) ,-(Ax) ") 

"add ea.Dx") 

"•dda ea,Ax") 

"addi idata.ea") 

"addq gdata.ea") 

"addx Oy.Dx" "addx -(Ay) ,-(Ax) ") 

"and ea.Dx") 

"andi idata,ea") 

"asr qdata,Dy" "asl qdata,Dy") 

"asr Dx.Dy" 'asl Dx.Dy") 

■b baddr") 

"b Dx.eal") 

"b iuord.eal") 

"bra baddr") 

"bsr baddr") 

"chk eal.Dx") 

•clr ea") 

"cap ea,Dx") 

"cmpa ca,Ax") 

"cmpi idata,ea") 

-cnpm (Ay)+, (Ax)+") 

"db Dx, iuord") ;Disp is itimediate IB bits 

"divu eal.Dx" "divs eal,Dx") 

"xor Ox,ea") 

"xori idata.ea") 

"exch Dx,Dy^' "exch Ax,Ay") 

"exch Dx.Ay") 

•ext Dx"i 

"imp eal") 

" sr eal") 

"lea eal, Ax") 

"I ink Ax, fuord") 

"Isr qdata.Du" "Isl qdata.Dy") 

"Isr Dx,Dy" *^t9l Dx.Dy") 

"•ove ea,dst-ea") 

"move eal.ccr") 

"wove eal.sr") 

"■ove sr, eal") 

"move Ax,usp") 

"«ovea ea.Ax") 

"woven iuord,ea") 

"movep d(Ay) ,Dx") 

"noveq qbyte,Dx") 

"»utu eal.Dx" "»ul8 eal.Dx") 

"nbcd ear) 

"neg ea") 

"negx ea") 

-nop") 

"not ea") 

"or ea.Dx") 

"or i idata.ea") 

"pea eal") 

"reset") 

"roxr qdata.Dy" "roxl qdata.Dy") 

-roxr Dx.Dy" Vox I Dx.Dy") 

-ror qdata.Dy" "rot qdata.Dy") 

"ror Dx.Dy" Vol Dx.Dy") 

"rte") 

"rtr") 

"rts") 

"sbcd Dy.Dx" "sbcd -CAy) ,-(Ax) ") 
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Ceiei cc 11 ea" ' -"B eal'l 

{'•0180 1110 0111 0010" 'stop iword") 

{-1081 rx dip 812© ea- "sub ea.Dx") 

(n001 rx sz-wl 11 ea" "«uba ea.Ax**) 

("0030 0100 size ea** "subt idata.ea") 

("0101 qdat 1 size ea" "subq qdata.ea") 

rXZZl rx 1 size 00 « ru" "subx Dy,Dx" "subx -(Ay) ,-(Ax) ") 

(-0100 1000 0100 rx" "suap Dx") 

("0100 1010 11 ea" "tax eaV) 

("0100 1110 0100 nib" "trap vector") 

("0100 1110 0111 0110" "tpapv") 

("0100 1010 Size ea" "tst ea") 

("0100 llie 0101 1 rx" "unlk Ax"))) 
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;-»- Mode: LISP; Package: ICONS; Base:S; Louercasetyes -»- 

The cached-page "page tab^e"* This array is indexed by page number. 
Its entrys are: 

NIL «■ page not referenced yet 

T ■» page has been referenced... tlust be read in if touched 
otherwise the entry better be a cached-page 
(defconst *cached-page- table* (make-array 1000, ' : type 'art-q)) ;wi I I grow if necessary 

;Cached pages 

(defconst «cached-page-stze» 2SG. ) 

(defsubst frames-per-page (size) (// (+ 14. (» size 3B.)) 15.)) 
(def struct (cached-page : named-array- leader 
: cone-name 

(:«akc-array (:type 'art-q : length *cached-page-size«) )) 
( I eng «cached-page-s i ze*) 
number 
wr i ttenp) 

;Cached pages are kept around as a resource, 
(dcfresource cached-page rconstructor (cons-cached-page) ) 
(defun cons-cached-page 
(loop with cp • (make-cached-page) 

for i from below «cached-page-size« 
do (setf (aref cp i) 0) 
finally (setf (cached-page-number cp) 0) 

(setf (cached-page-wri ttenp cp) nil) 
(return cp) ) ) 

(dsfun f ind-cached-page (number) 
■;; First make sure the page table is large enough... 
(let (deng (array-act ive- length »cached-page-tabte*) )) 
(if (2 number I eng) 

(setq *cached-page-table« (adjust-array-size *cached-page-table* 

(fix (» 1.5 (max I eng number))))))) 
;; Now see if there is an entry, if not, allocate one 
(let ((entry (aref *cached-page- table* number))) 
(if (or (null entry) (eq entry 't)) 

(let ((page (allocate-resource 'cached-page))) 
(setf (cached-page-number page) number) 
(setf (cached-page-wri ttenp page) nil) 
(if entry (swap-in-cachcd-page page)) 
(setf (aref »cached-page- table* number) page) 
page) 
entry))) 

:The cached a-mem, an entry of NIL means not written, otherwise a fix/big num 
(defconst *cached-amem* (make-array PolQQZd 'ttype *art~q)} 
(dofun cached-read-amem (adr) 
(or (aref *cached-ameffl« adr) 

(ferror nil "-.^Read from un-ini t iai izcd AMEn location -^. " adr))) 

(defun cached-wr i te-amcm (adr val) 
(setf (aref *cached-amem* adr) val)) 
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This is the routine that actually produces the "program" that is the 
disassemDler. ft takes as input a list of instruct tons, and returns 
a piece of code to disasseobie those instructions. 
The general algorithm is: 

1. If there is only a single instruction in the list, then return 
the code to disassemble it* 

2. If there is more that one instruction, go though all instructions 
in the list checking to see if there is some field of bits that 
is "constant" (ie. not part of something like an EA or REG field.). 
If such a field exists, return a program segment which is a "selectq" 
on that field. Recursivly call "generate- iookup-tree" to generate 
the code for the instructions in each "clause" of the selectq, 

3. If there is no common "constant" field, then generate an "IF" check 
for the instruction that has the greatest number of "constant" bits 
and recur se to generate the program segments for that instruction 
and the "rest" 

<defun generate- lookup-tree (mask Hist) 
(I oca I -dec I are ((special g-c-aask)) ;Greatest common aask 

(if (nul I (cdr i I ist)) 

;; The trivia! 1 instruction case 
(let ((insn (first ilist))) 

*(if (zerop (logand , (insn-«3sk insn) 

, . USS**®*" .(insn-const (first ilist)) instruction))) 
, (disassemble-G8k-instruction (first ilist)) 
(*throw •!! legal-BSK-Instruction ni I))) 
;; Here we have more than 1 instruction to decide between 
(let {(g-c-mask mask)} 
;; first see if there is tome "constant" field common to all instructions 
(dolist (i (list) 

(setq g-c-mask (togand Cinsn-mask i) g-c-mask))) 

(if (not (2erop g-c-mask)) 

;; Here we can compile a "setectq" on some field of the instruction 
;; First sort the instructions (under g-c-mask) then return the form 
;; Mselectq ( I ogand instruction ,maskr (val-1 clause-l ist-l) ... ) 
(loop for sorted- 1 ist on (sort (copy I ist tlist) 

#* (lambda (a b) 

{> (I ogand (insn-const a) g-c-mask) 
(I ogand (insn-const b) g-c-mask)))) 
wi th clause-l i st () 
and current-clause 
for first-insn • (first sorted-Iist) 

and second- insn ■ (and (cdr sorted-Iist) (second sorted-Iist)) 
for first- index • (I ogand g-c-mask (insn-const first-insn)) 
and second- index ■ (if second- insn 

•CI ogand g-c-mask (insn-const second- insn)) 

do (push first-insn current-clause) 
do (cond ((•• first-index second-index) 
(push • (, first-index 

, (generate- lookup-tree (logand mask (lognot g-c-mask)) 
current-clause)) 
clause-! tst) 
(setq current-clause ()))) 

finally (return Mselectq (logand instruction , g-c-mask) 
••clause-l ist))) 

;; Now the case where there is no common constant field 

;; Pick the instruction with the largest "constant" field* check for it 

;; with an "IF" and recurse on the "rest" 

( loop for insn in i I ist 

with largest-so-far • 8 
and bits-in-largest • -1 

for bits - (bl ts-in-word (logand mask (insn-mask insn))) 
do (if (> bits bi ts-in-targest) 

(setq bits-in-largest bits 
largest-so-far msn)) 
finally (if (zerop bi ts- in-largest) 

(ferror nil "Ambiguous instruct ions *S" Hist) 
(return Mif (• (logand instruction , (insn-mask largest-so-far)) 
• (logand (insn-mask largest-so-far) 

( insn-const largest-so-far) ) ) 
, (generate-lookup-tree mask 

(neons largest-so-far)) 
i , (generate-tookup-tree mask 

_ r ~ — 1 _„ _ ^remq largest-eo-far ilist))))))))))) 

This routine takes a list of "patterns" Jala ^instrucTion^pat terns*) and returns 
-a terant- nS??,.rn^Vf ^ -!m The only "speci al" pattern it knows about is the 
... dels as appropriate!'" * * ^' "''•" '* "" °"' °* '^"'^^ '* Oenerctes 2 insn 
(defun parse-instruction-list (ilist) 
(loop for i in i i ist 

with insn- I ist 

for b-pat - (pattern-expand-binary-pattern (first t)) 
for const - (first b-pat) 
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for Kask • (second b-pat) 
for b-fields - (cddr b-pat) 

for t-pat- list • (loop for p in (cdp i) collect (pattern-expand-tcxt-pattepn p)) 
do (let ((eel (assoc ^aJterant (cddr b-pat)))) 
(if (null sei) 

(push (nake-insn : const const 
tnasK nasK 
:b-pat b-fields 

:t-pat (first t-pat-list)) insn-list) 
(let ((pos (second set))) 

(setq wask (deposit-byte mask pos 11) 

b-fields (renq set b-fieids)) 
(push (nake-insn zconst const 
:«ask mask 
: b-pat b-fields 

:t-pat (first t-pat-Iist)) insn-list) 
(setq const (deposit-byte const pos ID) 
(push (aake-insn tconst const 
taask aask 
:b-pat b-fields 

:t-pat (second t-pat-l ist)) insn-list)))) 
finally (return insn-list))) 

This function takes a list of "irisn" structures and returns a list with various 
fields expanded". 

At the moment it only expands the "direction" field (by consing a new insn with 
the source and destination fields swapped, 
(defun expand-instruction-l ist (ilist) 

(loop with un-expanded - (parse-instruct ion-i ist ilist) 
wi th resul t-l ist • () 
with temp 

until (null un-expanded) 
for insn - (pop un-expanded) 

do (cond ((setq temp (assq 'direction (tnsn-b-pat insn))) 
(let ((pos (second temp)) 

it-pat (insn-t-pat insn))) 
(if (i* (length t-pat) 3) 

(ferror nil "dir field used on wrong length insn *A." 
t-pat)) 
(setf (insn-mask insn) (deposit-byte (insn-mask insn) pos 1 D) 
(self (insn-b-pat insn) (remq temp (insn-b-pat insn))) 
(push insn un-expanded) 

(setq insn (make-insn :const (deposit-byte (insn-const insn) pos 1 1) 
rmask (insn-mask insn) 
: b-pat (insn-b-pat insn) 
:t-pat (I ist (first t-pat) 
(third t-pat) 
(second t-pat)))) 
(push insn un-expanded))) 
(t (push insn resul t-I ist) )) 

finally (return resul t-l ist) )j 

; Routines to expand the text and binary patterns in **instpuct ion-pat terns*" 

A pattern is a string that contains tokens separated bu spaces. Tokens 
art either constants (represented by some combinaton of the characters 
"0" and "1") or variab/e fields. Variable fields are represented by various 
strings of alphabetic charcters. This routine parses the pattern 
according to the foMowing aJgorithm: 

Constant bits (ie "B-s or "I's) are accumulated the the var CONST. For each valid 
bit in CONST a corr isponding bit is set in nA5<. 

For each variable field a list of the form '(name f irst-bi t-pos #-of-bi ts-in-f ield) 
is made. 

This routine verifies that ail IS bits of the instruction are described 
, ,, by the pattern and then returns *(, const .mask »•! i st-of-var iable-l ists) 
(defun pat tern-expand-bi nary-pat tern (pattern) 
(loop with str-leng ■ (string-length pattern) 
and const - 
and mask • 
and bi t-pos - 16 
and component-! ist 

for str-pos • then wd-end 

for wd-strt « (str ing-search-not-char ^\sp pattern 0) 

then (or (str ing-search-not-char U\9p pattern str-pos) 
(if (or i^ str-pos str-leng) 

(char-equal /tr\sp (aref pattern str-pos))) 
•tr-leng str-pos)) 

until (or U str-pos str-ieng) 
(S bi t-pos 0)) 

for wd-end - (or (str tng-search-char #\sp pattern wd-strt) str-leng) 
for word • (substring pattern wd-strt wd-end) 

do (if (ttring-search-not-set * W/d U/1) word) 

;; Here if the entry is a pattern (ie. not just "0" and "l") 
(let ((entry (assoc word «b i nary-pat tern- ! i st«)) ) 
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(i f Cnul f entpu) 

if error nil '^^ad component name in instruction def -.S. " pattern) 
(let ((name (second entry)) 
(size (third entry))) 
(decf bi t-pos size) 
(push M,na«e ,bi t-pos .size) component- M st) ))) 

;; Here i f the entry is part of the "constant" specification 
(dotimes (i (sti- ing- length word)) 

(decf bi t-pos) 

(seta mask (togior mask (Ish 1 bit-pos))) 

(if (char-cquaT U/l (aref word i)) 

(setq const (logior const (Ish 1 bit-pos)))))) 



finally (if (or (•■ wd-strt str-leng) 
(* bit-pos 0)) 



(* bit-pos 0)) 
(ferror nil "Instr def -.^S doesn't specify 16 bi 
(return '(.const ,mask .•component-list))))) 



ts" pattern) 



; The text pattern is very fixed format. 

; The first part of the string is the opcode (terminated by a space). 
:roi lowing the opcode are the arguments separated bu commas. 
defun pattern-expand-text-pattern (pattern) 
(let* ((leng (string-length pattern)) 

(dehm (or (string-search-char tfXsp pattern) leng)) 
(opcode (substring pattern delim))) 
(loop for start • (1+ delim) then (1+ end) 

fof" «7d • ^0"" <9tring-search-char U/, pattern start) leng) 
unti I (2 start leng) * 

collect (let ((item (assoc (substring pattern start end) 
,.^ , ^. . ^ »text-pat tern- list*))) 
(tf (null item) 

(terror nil "*«!nvalid text pattern *S. ■ pattern) 
(second ite/»))) 
into cofflponent-l ist 

finally (return <cons opcode cpmppnenJj^Us 

;;; Helper for di sassemble-insturct ion 
(def macro add-format (string . arg) 

(if arg '(setq format-string (string-append format-string /string) 
fop»at-args (append tormat-args '.arg)) 
Msetq format-string (string-append format-string .string)))) 

:; This is the routine that takes an "insn" def and generates the code to produce 
;; the text string representing the disassembled instruction, 
defun d isassemb I e-bSk- instruct ion (insn) 
(let* ((b-pat (insn-b-pat insn)) 
(t-pat (insn-t-pat insn)) 
(format-string (pop t-pat)) 
(format-args ()) 
(instruction-bindings (loop for p In b-pat 

collect '(.(first p) (load-byte instruction 

, (second p) 

(source-bindings ()) ' ^^^'""^ P^^^^^ 

(destination-bindings ())) 

;; This is a hack to get the var "size" bound uhen either one of the 

;; size specifiers is used 

(if (assq ;8ize-wl b-pat) (push Msize (1+ size-wD) instruction-bindinos) ) 

(if (assq 'size-bul b-pat) (push '(size (if (> size-bul 2) omamgsj/ 

(fthrow \Illegal-68k-fnstruction nil) 
size-bwD) 
f t t * , , instruction-bindings)) 

(If (assq move-sz b-pat) (push '(size (cadr (assoc move-sz '((10) (3 1) (2 2))))) 

i nstruct i on-b i nd i ngs) ) 

;; Expand the fields that actually modify the opcode 
(if (assq 'condition b-pat) 

(add-fprmat ''-A" (nth condition mcondi t ion-codes*) ) ) 
(if (assq bitop b-pat) 

(add-format -^A^ (nth bitop «bi top-types*) ) ) 

?H^*f "^ *'i^S;^V'.5'P^*^ ^^''"^ "^slze-wl b-pat) (assq 'move-sz b-pat)) 
(add-forma t "^" (nth size «instruct ion-sizes«) ) ) 

;; This is basically just • big setectq on the various "text-pattern" fields 
(loop for form in t-pat 

for del im « ■ *• then "," 
do (add-format deUm) 
do (selectq form 

(dreg-x (add-format "D-^" regx) ) 
(dreg-y (add-format "D*^" regyU 
(areg-x (add- format "A^O" regx)) 
(areg-y (add-format "A-vQ** regy) ) 
(auto-dccr-x (add-format "-(A^)" regx)) 
(auto-decr-y (add-format "-(A*0)" regy)) 
(auto-incr-x (add-format "(A-^)*" regx)) 
(auto-incr-y (add-format "(A*vO)+" regy)) 
(indexed-displacoment (add-format "^A"^ source-string) 

(push '(source-string (print-ea (togior UoS^ regy) size)) 
source-bindings) ) 
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(quick-data {add-fop«at ■-^[18*':;*':*^'*'3 " q-data)) 
Cianediate-data (add-fortiiat 'Mm}" inmediate-data) 

(push * (iamediate-data (read-iamediate-data size)) 
instruction-bindings) ) 
(iBMediate-uord (add-foraat "^^^O" iaimediate-data) 

(push * (immediate-data (read-immediate-data D) 
80upcc-b i nd i ngs) ) 
(branch-address (add-format "-rA" branch-addp) 

(push • (bpanch-addr (ppint-bpanch-addp byte)} 
SOUPCB-b i nd i ngs) ) 
(immediate-disp (add-fopnat *'«^'' immediate-data) 

(push * (immediate-data (pead-immediate-data 1)) 
soupce-bindings) ) 
(destination-aa (add-fopmat "'^'A" dest-ea-stping) 

(push ' (dest-ea-stping (ppint-ea-swapped dest-ea size)) 
destination-bindings)) 
(ea (add-fopmat *'J(' aa-strtng) 

(push '(ea-stping (pp int-ea ea size)) 
soupce-b i nd i ngs) ) 
(ea-uopd (add-fopmat "'^A" ea-stptng) 

(push Mea-stping (ppint-ea ea 1)) 
souPce-bindings)) 
(vectop (add-fopmat "Vectop-'vO'' nibble)) 
(moveq-byte (add-fopmat "^-^O" byte)) 
(cc-pcgistep (add-fopmat "CCR**)) 
(usep-stack-pointep (add-fopmat "USP")) 
(status-pcgistep (add-fopmat "SR")) 

(othepwtse (feppop nil "Bad instpuction def. Unknown pattepn *A." fopm)))) 
• (Iet» (,a(npevepse instpuct ion-bindings) 
.•souPce-bindings 
,«dest i nation-bindings) 

f tPL"^* „"' ' • ^^r'A*^"'^^ '"0 tgfo pmat- apgs )))) 

;;; Hack poutrne 

(defun bits-in-uopd (uopd) 

(loop fop i - uoPd then (!sh i -1) 
unti 1 (zepop i) 
sum (if (oddp i) 1 0))) 

;;; This macpo genepates the "selectq" tpee fop bpeaking doun instpuctions. 
;;; This is the guts of the disassenblep 
(defmacpo genepate-disassemblep () 

(genepate-lookup-tpee -1 (expand- instpuction- I ist minstpuction-pattepns*))) 

F:>$y$>1ll>stancfard- image, lisp. 5 

;;;-«- flodeiLISP; Package:USER; Base:^,; Lowcpcase: t -*- 
;;; (C) Copypight 1S82 Symbolics Inc. 

(defmacpo Pot-l-lS (value) 
Mlet ((val , value)) 

(dpb val #08117 (Ish val -15.)))) 

;;; Mix this in to simulate the block pead/upite messages with pead/upite wopd messaaes 

(def flavor image-fake-btock-io-mixin ()) ^ 

(defmcthod (image-fake-block-io-mixin :wpi te-wopds) (apray offset addr n-uopds) 
(loop pepeat n-words 

fop i upfpom offset 

fop a upfrom addp by 2 

do (send self *:urite-uopd a (apef appay i)))) 

(defmethod (image-fake-block-io-mixin :pead-uopds) (appay offset addp n-wopds) 
(ioop pepeat n-uords 

fop t upfpom offset 

fop a upfpom addr by 2 

d o (setf (apef appay i) (send self 'ipead-wopd a)))) 

:;; Mix • image-cached-peads-m txin" befope a nopmal image to cache the pead data. 

(defconst image-cached-page-size tfolBd) 

(def struct (image-cached-page :named-appay-leadep rconc-name 

(:«ake-appay (rtype 'apt-lSb : length image-cached-page-eize) ) ) 
addr) 

(def f 1 avop i mage-cached-peads-m i x t n 

((«cached-page-act i ve-l ist* nil) ; these have good data 
(«c3ched-page-passive-l ist» nit)) ; these are empty 

(:pequi red-methods ;pcad-wopds) ) 

(defeethod (image-cached-peads-mixin t f tush-cache) 

(setq «cached-page-passive-l ist* (nconc *cached-page-act ive-1 ist« 

»cached-page-pass i ve- 1 1 st») ) 
(setq «cached-page-act ive-l ist* nil)) 

(defmethod (image-cached-peads-mixin :read-uopd) (addp) 
(setq addr (// addr 2)) 

(let ((pagcno (// addr image-cachcd-page-size) ) 
(offset (\ addr image-cached-page-size) ) ) 
(loop for page in *cached-page-act ive-i i st« 



1035 



4,887,235 



when (- 
f i na i I y 



(image-cached-page-addr page) pageno) return (are 
(let ((npage. (op (pop *cached-page-pas3i ve-l i st*) 
(wake- i mage-cached-page) ) ) ) 
(setf (image-cached-page-addr npage) pageno) 

5lf 'rread-uords npage 8 (« (- addr off 
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page offset) 



(send se 



sc I I .rc<aa-worn5 npage 
i «age-cached-page-5 i ze) 
(push npage «cached-page-act ive- 
(return (aref npage offset) })))) 



set) 2) 



list») 



(def leethod ( i wage-cached-reads-a i x i n 

(send self ': f lush-cache) ) 
(def«ethod ( i«age-cached-reads-«ixin 

(send self *: f lush-cache) ) 
(defoethod ( image-cached-reads-arxin 

(send self *: f lush-cache) ) 
(defacthod ( i mage-cached-reads-«i x i n 

( send se J f *: f lush-cache) } 



I before 



:write-uord) Cirest ignore) 
: before :wrl te-«ords) C&rest ignore) 
: before : reset- image) (&rest ignore) 
: before :goto) (Arest ignore) 



laages 



;;; A debugger mix in for B8C88 
(def flavor image-debug-wixin 

( «ddt-point« «pQtnt-open-p« 
«r ight-vatue* «l«f t'value* «va/ue-' 
»mode3t 

*defaul t-mode* 
(*addres9-stack« nil) 
«type-out- length* 
« type-out- values* 
« I ast-address-pr i nted* 
«locat ion-to-tao-to*) 

: se t tab i e- i ns tance-var i ab I es 
(.•required-methods : read-word :wr i te-word) ) 

(def method (imaae-debug-mixin : debug) 

(setq *mode* "^(symbolic 1) «def3uTt-inode* * (eumbo 
*ddt-point* *point-open-p* nil 
♦right-value* 9 *left-vatue« 
♦value-valid* nil «arith-op* *+ 
«type-out- length* «type-out-values« nil 
«iast-address-printed* nil «locat ion-to-tab-to« nit) 
(♦catch exit-debugger 
(do (()) 

(error-restart-loop (sys:abDrt "Back to the BSk debugger") 
(send standard-output *: fresh- 1 ine) 
(*catch *debugger-cmd-error 

(loop for ch - (funcafi standard- input *!tyi) 

do (if {< ch 200) (funcall standard-output 
i . m ^^i^?""^ "'* 'sdebug-process-char ch))) 
(princ 7{? **) 
(use-value))))) 



tusual ddt style hackery 
•val id* «ar i th-op* 

;list of mode name and "args" (repeat count) 
;inode *- default on a CR. 

'*^??'"iv!'^"S*^^ °^ P'3ce we "jumped" from 

; tells ff\lf how far to jump forward 

;A list of all words last command typed out 

; setup by the disassembler routines 

;set in routines that open/close locations 



ic 1) 



tyo ch)) 



(def method (image-debug-mixin :debug-process-char) (ch) 
(if (and U ch tt/Q) (i ch t(/3)) 
(setq *r ight-vatue* 
♦value-vaf id* 
(selectq ch 
iU/\ 



t) 



(Ish mrtght-vatue* 3) (- ch tf/0) ) 



(setq 

(cond 



♦value-valid* (funcall self ': lookup-value (read standard-input))) 
(«vatue-val id* 
(setq «right-value* *v3lue-va! id^ 

♦vatue-val id* t) 
(do-ar i thffletic) ) 
(t (♦throw 'debugger-cmd-error t)))) 
(^\help (format t "'vgC-z to exit.")) 
{{tf/+ U\sp) (do-arithmetic)) 
itt/~ (do-arithmetic) (setq ♦arith-op* *-)) 
iff/, (setq *r ight-value* ♦ddt-point* 

*varue-val id* t) 
(do^ar i thmetic)) 

(if «value-valid* (setq *type-out-vaIues* (list (use-value)))) 
,i<52'l^* ^"cl *type-out-values*) (format t " -^ " wd))) 
iff/tt (send self :descr ibe-instance 

(Mis lookup-type (pkg-bind 'Ml (read standard-input))) 
♦ddt-point*)) 
#/! ft/*') 

*value-valid*) (*throw 'debugger-cmd-error t) 
ch ff/l) (setq *mode* '(octal 1))) 
ch ^/") (setq »mode* '(ascii 2))) 
(push-*ddt-po ( nt*) 
(setq *ddt-point* (use-value) 

*left-value* 0) 
(if {.- ch tf/\) 

(open- location) 
(format t " ") 
(setq «point-open-p* t))}} 
(<^\return (terpri) 
(close-location) 
(setq *mcde* *defaul t-mode*) ) 
((#/- ^\c-h) 
(close-location) 
(decf ♦ddt-point^ 2) 



iitf// nn 

(if (not 
(if (- 
(if (. 
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(prompt-address) 

(open- location)) 
(#\lf 

(close- location) 
-(incf «ddt-point» «type-out-length») 

(prompt-address) 

(open-location) ) 
(;?\tab 

(close-location) 

(push-«ddt-point«) 

(setq *ddt-potnt* (or «locat ion-to-tab-to« «ddt-point«) ) 

(prompt-address) 

(opcn-locat ion) ) 
Mf\c-Z (*thPou *e)ct t-debugger t)) 
(A?\c-I (send standard-output 'rclcar-screen)) 
«f\alt (send self * :debug-proccss-al tmode) ) 
Jotherni se (»throu 'debugger-cmd-eprop t))))) 



(def method (inage-debug-Mtxtn idebug-process-ai tiiode) 
(let ((ch (funcalt standard- input ':tgi))) 
(if (and it ch ff/a) is ch U/z)) 

(setq ch (- ch (- »/a JST/A) ) ) ) 
(funcall standard-output *;tyo ch) 
(selectq ch 

((#\return #\lf} 
(let ({addr-ien (pop staddpeas-stack.*) ) ) 
(if (null addr-len) <princ " ?no-st3cR ") 
(tctq «ddt-point« (first addr-len) 

«type-out- length* (if (» ch U\return) 

8 (second addr-len)))) 
(send self ' tdebug-proccss-char MWi))) ;hack 

(#/G 
(if (or (not (wernq 'goto (send self ' :which-operat ions) ) ) 
(not *value-vat id*) ) 
(«throu 'debugger-cind-error t)) 



(setq »ddt-point*"Tuse-value)) 
(send self :got 



:goto «ddt-point«) 
(if (memq *;talk (send self * :which-operations) ) 
(send self * stalk))) 

«r/T 

(If (not (memq *:talk (send self 'tuhich-opcrations) )) 

(«throu 'debugger-csid-error t)) 
(send self *: talk)) 
(#/D 
(if (not immma 'rdump (send self ' :which-operat ions) )) 

(♦throw •debugger-cmd-crror t)) 
(send sel f *:dump)) 

in/? 

(if (not (»emq 'swhy (send self ' ruhich^operations) )) 

(»throu •debugger-cmd-error t)) 
(funcall standard-output * :cl ear-screen) 
(send sel f * :uhy) ) 
(otherwise («throw 'debugger-cmd-error t))))) 

(def method (iwaae-dcbug-wixin ruhy) (^optional (rg #o7080) ) 

(format t "^n^ZA") * k ^ 

(let* ((fp (send se»f •:read-fong U rg 78))) 
(«p (send self *:read-long (+ rg 74))) 
(trapn (send seH 'tread-word (+ rg 168)))) 

(loop for reg in ' (D8 D4 A8 AA) 
wi th loc « rg 

do (format t "-« ^ «" reg) 
(loop repeat 4 

do (format t "'•130" (send self 'tread-long loc)) 
(incf loc 4))) "* . 



(format t "-^Z&Sp « *0, Fp - *0, " sp fp) 
(cond ((or (- trapn 8.) (« trapn 12.)) 



(if (- trapn 8) (format t "Bus error") (format t "Address error")) 

(format t **^Trap block Fen - ^, Addr » ^, Ir - *0, Sts - ^, Pc « '^AC-^)' 

(send self :read-word sp) 

(send self *sread-long (+ sp 2)) taccess addr 

(send self 'tread-word (+ sp 6)) ;ir 

(send self ': read-word (4- sp 8)) ;st8 

(send self 'tsunbol ic-address 



(send eeTf 'tread- long (+ sp 18.)) 288) 
(send self 'tread- long (+ sp 18.))) ;pc 



Ji«5^>^*ill^^c » /-. * // 11 laccount for 7 wds of stuff on stack 

((and (i trapn IB.) (S trapn 44.)) 

(format t "-^A" (nth (// (- trapn 16.) 4) 

•("Illegal insn" "Zero div" "CHK insn" "trapv insn" 
. ., Pf^iv violation" "Trace" "op 1818 trap" ""op 1111 trap"))) 
(format t "*ATrap data Sts - -0, Pc - -^(--^0)" ^ y ^^^^ ^^^y 

(send self 'tread-word sp) 

(send self ': symbol ic-address (send self 'tread- long (+ sp 2)) 288) 
(send self 'tread- long (+ sp 2))) 
(incf sp 6.)) 
((• trapn 8) 

(Format t "No trap taken...")) 
(t (format t "Unknown trap - *0. " trapn))) 
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;; Loop over alt frames 
( loop uhl le (< 8p rg) 

do (if (or (< fp sp) (a fp rg)) 

(return (format t *'*dScreued up stack ... Sp - *0, Fp - '^, Ro « -^" 
sp fp rg))) 
(let* ((rts (send self 'iread-long (+ fp 4))) 
(nfp (send self * tread- long f p) ) 
(pc (send self 'tread-long (- rts 4)))) 
;; Try to print out the name of the function this frame belongs to. 
(format t -rZ&Frame for fen *A:" (send self 'tsymbol ic-address pc 280)) 

;; Loop over all word in the frame 
(loop unti I (2 sp fp) 

for ud • (send self *:read-uord sp) 
for Ig m (send self * tread- long sp) 
do (format t "-^^^ZX-IZO: -.70" sp ud) 
(if (< sp (- fp 2)) 

(format t ^ -^120" lo)) 
(incf sp 2)) 

;; Now print the fp & rts linkage words 

(format t "-^-llXNfp: -^" nfp) 

(format t -*^llXRtst ^" (send self ': symbol ic-addr ess rts 283)) 

(setp sp {•¥ fp o) 

(for-at t"^-)))'^__":P''^'.. 

(def method ( image-debug-mixin t describe- instance) (type point) 
(if (eq type Ti I twtundef ined-typeiw) 
(format t "-^^ndef ined type*) 
(let ((type-type (/ i I t type-type type))) 
(format t "--^Type is -^A" type-type) 
(selectq type- type 

(liltpointer Idescribe-po inter-type type point)) 
(li Itcomposi te (descr ibe-composi te-type type point)) 
(otherwise (format t ", which has no describe support."))) 
(format t '*^")))) 

(defun-method descr ibe-pointer-type image-debug-mixin (type point) 
(let ((pointer (send self ':read-!ong point)) 
(ntype ( I i t : type-pointed-to type))) 
(format t "^ointed-to structure is a *A at ^" (M I : type-name ntype) pointer) 
(send self ': descr i be- instance ntype pointer))) »f- k 

(defun-method descr ibe-composi te-type image-debug-mixin (type point) 
(let ((type-inciuded-type ( I i I : type-incTuded-type type))r 

(when type-included-type (descr ibe-composi te-type type-included-type point))) 
(describe-cpe ( I i I t type-cpe type) point)) yn h w 7 / 

(defun-method describe-cpe image-debug-mixin (cpe point) 
(selectq ( 1 i I :cpe-type cpe) 

(liltelement (let* (tloc (+ point (// ( I i I tcpe-of fset cpe) 8))) 
(body- type ( I i 1 tcpe-bodu cpe) ) 
(value-Bsg (selectq ( i i T: type-size body-tupe) 
(1 'tread-byte) 
(2 'tread-word) 
(4 'tread- long) 
, ^ (otherwise '(f)))} 
(format t "^^4^// Slot is -^ (-*A)" 

, ^ loc (I i l:cpe-name cpe) ( M I t type-nane body-type)) 
(when value-msg » »k 

,,., ,, (format t ", value - ^" (send self value-asg loc))))) 
( 1 1 i t sequence (loop for cpe tn (1 i t:cpe-bodu cpe) 
do (describe-cpe cpe point))) 
(dltunion (describe-cpe (c^r (last (I i I tcpe-body cpe))) point)))) 
t ; ; Uti I i ty functions 
(def met hod ( image-debua-wixtn :du»p) 
(let* ((sp (send self 'tread-word UoldlS)) 

(start (Max no^^^^ (min ^oGsea (- sp ibh)) 

(first-byte (dpb 8 <fo8883 start)) 
(last-byte #o7ll7)) 
(loop for i from first-byte to last-byte bu ^S'oZS 
do (format t "-^ *90 - " i) 
(loop for i below #o28 by 2 

,^ .,, do (format t * -^/eO" (send self 'tread-word (+ i j)))))) 
iterpr ) ) ) 

(defun-method close-locat ion i«age-debug-mixln 
(do-ari thmetic) 

(if (and *potnt-open-p* *value-val id*) 
(let ((value (use-value))) 

(send self 'twrite-word «ddt-point* value) 
(setq «loc3tion-to-tab-to« vaiue))) 
(use-value) ) 

(defun-method push-*ddt-point* i«age-debug-mixin 

(push (,*ddt-pornt* ,»type-out-Tength*r «address-stack*) ) 

(defun-method open- location image-debug-mixin 
(setq *point-open-p« t) 
(selectq (car *mode*) 
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(octal' (setq «type-out-values« (loop repeat Ccadr «mode*} 

for r upfpow «ddt-pomt« by 2 
for ud - (send self *:read-word i) 
col (ect ud 
i . . .. , ^ .*^o (fornat t ' ^ ' u6))) 

(setq *type-out-length* {« 2 (cadr atmode*))) 
(setq «location-to-tab-to« (car (last «type-out-values*) ))} 
(symbol ic 
(setq « last-address-printed* niH) 
(setq »type-out-length» 8) 
(setq »type-out-values* n'ti) 

(format t " *A " (send self * :dtsassemble-B8k) ) 

(setq «!ocation-to-tab-to* (or «last-address-pr inted* (car (last «type-out-values«) )) )) 
(ascii (setq «type-out-values* (loop repeat (// (cadr «mode») 2) 

for i upfpom «ddt-point» by 2 
, , , . , collect (tend self 'iread-wopd i))) 
(setq «type-out- length* (cadr »«iode») ) 

(setq *location-to-tab-to* (car (last «type-out-value8«})) 
(loop repeat (cadr «fflode») 

for i Lipfroin *ddt-point* 
do (tyo (send self •:read-byte i)))) 
(otherwise (ferror nil "bad node") )) ) 

(defun-method prompt-address image-debug-mtxtn 

(cond ((memq ': symbolic-address (send self * ;uhich-operat ions)) 

(format t"-^//** (send self 'isumbol ic-address *ddt-point* 200))) 
(t (format t "^^-O// " »ddt-point«r))) 

(defun-method do-ar i thmet tc image-debug-mixin 

(setq *left-valuc« (funcall «arith-op« »left-vaiue* «r ight-vatue*) 
*r ight-valuc* 
*arith-op« •+) 
*lef t-vaiue*) 

(defun-method use-value i«age-debug-mrxin 

(do-arithmetic) 

(progl »left-vafue» (setq *left-value* 

«value-val id* ni I))) _ 

;;; This file contains the actual disassembler erd all routines that it calls 

;;; It is not necessary to have the "generate" file loaded to use the disassembler 

(defconst «condi t ion-codes* 

'(**t" -f" "hi" "Is* "cc" "cs" "ne" "eq" 
"vc" "ve" "pi* "»i" •ge" "It" "gt" "le")) 

(defconst *instruct ion-sizes* 



(defconst *bi top-types* 

• ("tst" 'chg- "clp" 



chg" "clp" "tet")) 

;:; Routine to process the 8 bit "branch" field of branch-class instructions 
(defun-method pr int-branch-addr iaage-debug-mrxin (bute) 
(let ((addr (+ 2 *ddt-point* * « « 

(disasse-ble-iddri'srSSdry))^ <read-i«ediate-data 1) (eign-extend-byte byte))))) 

;;; Routines to generate the strings for "ea" type fields 
(defun pr tnt-ea-swapped (ea size) 

(print-ea (dpb ea 1^00303 (tsh ea -3)) size)) 

(defun-method print-ea image-debug-mixin (ea size) 
(let ((mode (Idb #00303 Sa) ) 
(reg (Idb #00003 ea))) 
(setectq mode 

(0 (format nil "0-0" reg)) 

(1 (format ni t "A^" reg)) 

(2 (format ni I "(A^)- reg)) 

(3 (format nil "(A^)+" reg)) 

(4 (format nil "-(A-O)" reg)) 

(B (format ni I "*0(A^)" (mask-to-word (read-immediate-data 1) ) reg)) 

(b (let* ( (wd (get-next-uord) ) 

(da (if (zerop (Idb #ol701 wd)) "D" "A")) 
(sz (if (zerop (idb#ol301 wd)) "w" "1")) 
(ireg (Idb #ol403 wd)) 

(disp (sign-extend-byte (Idb #00010 wd)))) 
(format nil "-0(A^, *^^.^A)" disp reg da ireg sz))) 
(7 (selectq reg 

((0 1) (disassemble-address (mask-inmediate-data 

tn M * /r -i- / ^^ (read- immediate-data (1+reg)) (1+reg)))) 

(2 (let ((addr (+ *ddt-point« «type-out-length*)) ^ 

(extn (read- immediate-data 1))) 
(dtsassemble-addrcss (+ addr extn)))) 
(3 mode 7 reg 3 not done yet") 
(4 (string-append **#" 

(d i sassemb I e-addr ess 

(mask- immediate-data (read-immediate-data size) size))))))))) 
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(defun-method di aasscmb le-address image-debug-iiixin (addr) 
(setq *!ast-actdress-pr inted* addr) 

<cond ({memq •; symbol ic-adaress (send self ' twhich-operat ions) ) 
(send self ': sumboi ic-address addr 280)) 
(t (format nH jvQ^addr) ) ) ) 
; Routines to impjement a general purpose interface to the dtsassembler, 
; All the user has to do is define a Benory-read" function. 
.• Routine to fetch next word from the instruction stream 
defun-method get-next-word iRage-debug-mixin 
(let* ((addr (+ »ddt-potnt» »type-out-tength*) ) 
(uord (send self ':read-uord addr)!) 
(incf «type-out- length* 2) 
(if «type-out-values* (pplacd (last «tupe-out-values*) (neons word)) 

(setq *type-out-values* (neons word) J) 
uord)) 

;;; Routine to read immediate data (of size byte/word/ long) from the instruction stream 
(defun read-immediate-data (size) 
(eased size 

(0 (sign-extend-byte (get-next-uord>) ) 

(1 (sign-ext end-word (get-next-uord) )> 

(2 (sign-ex tend- long {+ (ish (get-next-word) 16.) (get-next-word)))))) 

(defun mask- immediate-data (val size) 
(caseg size 

(0 (mask-to-byte val)) 
(1 (mask-to-word val)) 
(2 (mask-to-long val)))) 

(defun sign-extend-byte (val) 

(if (> val Uolll) T- val #o400) val)) 
(defun mask-to-byte (val) 

(togand val Uo211)) 

(defun sign-extend-word (val) 

(if (> val Uolllll) (- val Jyo200000) val)) 
(defun mask-to-word (val) 

(logand val UolllUl)) 

(defun sign-extend- long (val) 

(if (> val no\llllllllll\ {- val #040000800000) val)) 
(defun mask-to-long (val) 

(logand val no27111117771)) 

•;; This i« it. -« , ,» 

(def method (image-debug-mixin zdisassemble-bok) () 
(let* ((instruction (get-next-word)) 

(string (if (not (zerop instruction)) ;hack to disassemble as 
(*catch • II legal-68k-Instruct ion (generate-di sassembler) ) ) ) ) 
;; Generate-di sassembler returns nil if the instruction wasn't valid 
(If (null string) (setq string (format nil "*^" instruction))) 
string)) 

(def f I avor i mage-symbo I s-« i x i n 
( (symtab m I ) 
(sorted ni I)) ()) 

(def method (image-symbol s-mix in tclear-symtab) C) 
(if symtab (setf Tfi I I-poin ter symtab) 0))) 

(def method ( image-symbol s-mix in tadd-symboi) (sum val) 

(if (null symtab) (setq symtab (make-array 103 *:type 'art-q *: leader- I i st ' (0) ) ) ) 

(setq sorted ni I) 

(array-push-extend symtab icons val sym))) 

(defmethod (imaae-symbol s-mixin : lookup-symbol ) (addr) 
(if (nul I symtab) 
nil 
(cond ((not sorted) (sortcar symtab '<) (setq sorted t))) 
(loop for i being the array-elements of symtab 
unt i 1 (> (car !) addr) 
for previous ■ i 
f tnal ly (if previous 

(return (cdr previous) (- addr (car previous))) 
(return ni 1))))) 

(defmethod ( image-symbol s-»ixin : lookup-value) (symbol) 
( i f (nul I symtab) 
M) 
(loop for i being the array-elements of symtab 
when (string-equal symbol (cdr i) ) 
return (car i) 
finally (return M))))) 

(defmethod (image-symbol s-mixin : symbof ic-address) (addr max-off) 
(multiple-value-bind (sym off) (send self ': lookup-symbol addr) 

(if (and sym (< off max-offl (i- addr off)) ;dont allow symbols at zero 
(format ni! "-vA^ [-f-Q^] " sym (if (zerop off) nil off)) 
(format ni I •'-^" addr)))) 
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;{defun dump-mem (^optional Istart #oB009 startp) (nwords (if startp #o40 ffoU^Q))) 

; (let < (arry (make-arrau <^ol08 'rtype 'apt-lSP)) 

; (first-byte (dpb S X'oae^S start)) 

; (last-byte (loaior 7 U «tart (« 2 nuords))))) 

; Cl.oop for I from ?irst-byte to ^ast-byte by tfo288 

; for uords-in-blk « Twin (// (1+ I- last-byte (})2) #ol03) 

; do (funcall «image* ':read-wopds arry 9 i uords-in-blk) 

; (loop for i below words- in-b Ik by ffolB 

; do (format t "-^ ^30 - " T+ i (» j 2))) 

: (loop for k below ^ol9 

: do (format t " -6/90" (aref arry (+ j k) ))))))) 

; ; ; An imitation of ICR's CRC program. Just to figure out checksums by hand. 

(defun cck (Arest bytes) 
(loop with check - #oB5555 
for byte in bytes 

do (setq check (logxor {rot-1-16 check) (logand byte iSfo377))) 
finally (return (logand <ro377 (I eh check -8)) (logand Xro377 check)))) 

; (defun tst-blk (&optional (nuords 199) (addr 39999)) 

; (let ((arry (make-array nwords ' : type 'art-lGb)) 

; { image vimaqe*) ) 

; (loop for t below nuords do (setf (aref arry i) 9)) 

; (funcall image ':ur i te-uords arry 9 addr nuords) 

; (funcall image ': read-words arry 9 addr nwords) 

; (loop for i below, nwords 

; do (if (not (zerop (aref arry i))) (ferror nil "Urong data in array?")) 

; (setf (aref arry t) i)J 

; (funcall image * ;wr i te-words arry 9 addr nuords) 

; (funcall image ':read-uords arry 9 addr nuords) 

; (loop for i below nuords 

; do (if (»» (aref arry i) i) (ferroj- nil "Urong data in array?"))))) 

F:>lmach>fep>Para11el-'port7Tlsp.8 



??! "*" J^ode: LISP; Package: LIL; Base: 8; Lowercase: Yes -«- 

;;; The para I lei -port ftavor implements a packet mode communicaton with the fep, 

;;; The basic message commands for sending are: 

;;; : send-mcssage-header-to-fep 

;;: ;send-s ingle-part-message- to- fep 

; ; ; : f int sh-sending-message-to-fep 

; ; ; For receiving are 

:;; :recei ve-message-from-fcp 

; ; ; : f i-ntsh-recei ving-message-from-f ep 

;;; For sending parts of message 

;;; : scnd-byte-array-to-fep 

; ; ; : send-byte-to-fep 

; ; ; :8end-uord-to-fep 

;;; :send-addr-to-fep 

; ; ; : send- 1 ong- to-f ep 

;;; For receiving parts of messages 

;;; :recei ve-byte-array-from-fep 

:;; :recei ve-byte-from-fep 

;;; :recei ve-uord-from-fep 

;;; :recei ve-addr-from-fep 

;;; irecei ve-long-from-fep 

(def flavor para I lei-port 

((♦ppr-addres5* <fo7BA12G) 
(♦checksum* /!fo55555) 
(♦trace* nit)) 

: set tab 1 e- i ns tance-var i ab J es) 

(defsubst read-ppr (!Cuni bus-read /!^o7SA126)) 

(defsubst urite-ppr (val) (Xunibus-wr i te ^o76412B (logand val #ol77777))) 

(defmethod (parallel-port :send-message-header-to-fep) (byte-array offset nbytes) 
(send self ' :abort-to-fep) 

(send self *: send-by te-array-to-fep byte-array offset nbytes) 
(send self * : send-word-to-fep *checksum*) 
(setq *checksum* /!^oBoB55) ) 

(defmethod (parallel-port : f ini sh-sending-message-to-fep) 
(send self * : send-word-to-fep «checksum*)) 
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(defmethod (parai lei-port !send-stng!e-part-message-to-fep) (Sreat args) 
(lexpr-send self ' : send-message-headerrto-fep args)) 

(defmethod (para! iel-port : send-byte-array-to-fep) (byte-array offset nbytes) 

(setq «checksurn* (cysttsend-bytes *ppr-address« *checksuni* nbytes byte-array offset))) 

;;; Slew debugging version 

;(defmethod (parallel-port : send-by te-array-to-fcp) (byte-array offset nbytes) 

; (loop for i from offset below (+ offset nbytes) 

; do (send self ' : send-byte-to-fep (aref byte-array i)))) 

(defmethod (paral lei -port tpeceive-message-from-fep) (opcode) 
(setq *checksum* #c55555) 

(let ((rcvd-opcode (send self * :receive-wopd-from-fep) ) ) 
(if (0 opcode rcvd-opcode) 

(ferror "Fep protocol error. Received opcode -vQ 1* expected ^. " pcvd-opcode opcode)) 
rcvd-opcode)) 

(defmethod (parallel-port trecei ve-byte-array-from-fep) (byte-array o.ffset nbytes) 

(setq «checksuni* (sys:Xrecei ve-bytes «ppr-address« «checksum* nbytes byte-array offset))) 

(defmethod (parallel-port : f ini sh-receiving-message-from-fep) 
(let* ((expected-chk ^checksum*) 

(received-chk^ (send self * :receive-uord-from-fep) ) ) 
(uhen im expected-chk recel ved-chk) 

(ferror "Checksum error. Expected *0, received ^. " expected-chk rece t ved-chk) )) ) 

;;; This for "old protocol - escape to new" 
(aefmethod {parallel -port :abort-to-fep) 

(mul tiple-vaiue-bind (ignore response) (expedient-fep-extended-command 5) 
(if (* response 3) (ferror "Wrong response -.0, " response))) 

(setq »checksuin* ;S?c55555J) Munse;;; 

;;; This is needed inorder to be an "image" to the linker... 
(defmethod (parallel-port :reset-image) 

(send self *:goto (send self 'tread-word S)) 

(loop while (bit-test 1_15. (read-ppr))) 

(wr i te-ppr -1) ( ii. 

(loop until (bit-test 1_15. (read-ppr))) ' "' thereset error. 

(wr i te-ppr 8)) 

''(::nTse^;'-:g;;:^-?00^0i=*^^*-^'^-'"''^'"-^^^^^ » 

(wr i te-ppr -1) 

(process-wai t-wi th-t imeout "FEP init" r* CO iq \ #• / 1 - ^_. /» , . 

(if (not (bit-test 1.15 (read-pir))) ^^'^ * "^""'•'' " (bit-test 1.15. (read-ppr)))) 

iurnZTel)''^"' ''""' '" -'t'-"«- The program loaded uas probably urong.')) 

;; This for the "hack prom" 

(defmethod (parallel-port :abort-to-fep) 

(loop do ^™"';^P;^-3'-e.bind (resp code) (send self -pp-transact 7 12.) 
ise t eciq cooe *" 

(3 (tyo (logand ;!fo377 resp))) 
(7 (return)) 

(setq *c.ecKl:lT7oilkslr°'' "" """"'^ '"' ''"''"' "'' '^- ^'<P«^''- -"-t." code))))) 

(defmethod (parallel-port : send-byte-to-fep) (byte) 

setq .checksum* (logxor (rot-1-16 .checksum.) (logand byte #o377))) 
(loop do (multiple- value-bind (resp code) Dyie»oj//))j 

(^lecJq'code' "'■"■'""'' "»9io'-2.12. ( logand #o377 byte)) ) 
(1 (return)) 

(3 (tyo (logand ^o377 resp))) 

(otherwise (ferror nil "Send byte received code -0. Expected an acK" 
code) ) ) ) ) ) 

(defmethod (parallel-port : send-word-to-fep) (word) 
(loop for ppss from #o0918 to tfoieiB by tfol030 

do (send self ': send-byte-to-fep (tdb ppss word)))) 
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(defmethod (parallel-port : send-addr-to-fep) (word) 
(loop for ppss from ^00018 to ffo22ld by ffol^^^ 

do (send self * tsend-bytc-to-fep (idb ppss word)))) 

(defmethod (parallel-port : send-long-to-fep) (word) 
(loop for ppss from ffoQZld to #o3019 by ;!rol000 

do (send self *: send-by te-to-fep (Idb ppss word)))) 

(defmethod (parallel-port : send-nbgtes-to-f cp) (nbytes word) 
(loop repeat nbytes 

for ppss upfrom #00810 by #ol088 

do (send self * : send-byte-to-fep (Idb ppss word)))) 

(defmethod (parallel-port trees fve-byte-from-fep) (^optional (randomness 8)) 
(let ((byte (loop do (mu( t fpte-value-bind (resp code) 

(send self ';pp-transact (logior 1_12. (logand randomness #o377))) 
(setectq code 

(2 (return (logand #o377 resp))) 
(3 (tyo (logand tf o377 resp))) 
(otherwise 
(ferror nil "Receive byte rcvd code -vO, Expected data" code))))))) 
(setq *checksum* (logxor (rot-l-lB «checK8um«) (logand byte tfo377))) 
byte)) 

(defmethod (parallel-port :receive-word-from-fep) 
( loop wi th rv » 8 

for ppss from #o8010 to <fol818 by *rol808 

do (setq rv (dpb (send self ' :receivc-byte-from-fep) ppss rv) ) 

finally (return rv))) 
(defmethod (parallel-port :recei ve-addr-from-fep) 
( loop wi th rv » 

for ppss from #00818 to #o2816 by #01888 

do (setq rv (dpb (send self * ;rcceive-byte-from-fep) ppss rv)) 

final ly (return rv) )) 

(defmethod (paral lel-port irecet ve-tong-from-fep) 
( loop wi th rv - 8 

for ppss from #08010 to #o3010 by #ol083 

do (setq rv (dpb (send self * :receive-byte-from-fep) ppss rv) ) 

final ly (return rv) ) ) 

(defmethod (paral lei -port :receive-nbytes-from-fcp) (nbytes) 
(loop wi th rval « 8 
repeat nbytes 

for ppss upfrom.#o8010 by #ol000 

do (setq rval (dpb (send self * :receive-byte-from-fep) ppss rval)) 
final ly (return rval))) 

(defmethod (parallel-port :pp-transact) (word 4aux resp) 
(wr i te-ppr 8) 
(loop repeat 18838» 

when (rerop (read-ppr)) return ni ! 
finally (ferror "Fep appears to be dead.")) 
(wri te-ppr (Idb #00017 word)) 
(wri te-ppr (logior 1.15. word)) 
(loop repeat 10800. 

when (bit-test 1„15. (read-ppr)) return nt I 
finally (ferror "Fep appears to be dead.")) 
(setq resp (read-ppr)) 
(wri te-ppr 8) 

(if «trace* (format t "-^^ut *0, In *0." word resp)) 
( va 1 ucs r e sp (I db # ol 4 83 r e sp ) ) ) 
(defmethod (parallel-port :talk) 
(loop for ppr m (read-ppr) 

do (if (bit-test 1_I5, ppr) 

(cond ({• (Idb #ol403 ppr) 3) 
(tyo (Idb #00818 ppr)) 
(wri te-ppr 8) 

(process-wait **?? wait" #* (lambda (not (bit-test 1J5. (read-ppr))))) 
(wri te-ppr -1)) 
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(t (Format T "^ifJon character data parallel port conmand. I quit.") 
(return))) 
(wri te-ppr -1) 
(pro cess-wait "PP nai f ft* (lambda (bi t-test 1.15. (read-ppr) ) ) ) ) ) ) 



This is the "old" protocol that talks over the para//sf pert. 
Included now just because it's fast. 
Protocol to bootstrap program in PEP EPROfl, using the IB-bit parallel port. 

Each machine presents the other machine with IB bits, consisting of 15 data 
bits and 1 sync bit. A 4-way handshake is implemented using the sync bits. 
Uhen the sync bit (s 1, the remaining 15 bits of data are valid; note that 
it is necessary to re-read the data bits after discovering that the sync bit 
is 1, since the hardware does no deskewing. 

The word from the Lt1-2 consists of 3 command bits and 12 data bits. The 

word irom the FEP contains just 8 data bits, except that when the response 

is "echo" the FEP echos back ail 15 bits from the Ln-2. Commands are as follows: 



Command Data 




Response 





addr 


<11:8> 




1 


addr 


<11:8> 


data <7:8> 


2 


addr 


<11:0> 


data <7:8> 


3 


addr 


<11:8> 


success 


4 


addr 


<11:8> 


success 


5 


addr 


<23: 12> 


success 


5 








8 


ignor 


e 


reset 


1 


ignore 




2 


ignor 


e 


data <15:8> 


3 


data 


<7:8> 


success 


4 

7 


data 


<7:8> 


success 
cmd error 



'data" reg. Return 
'data" reg. Return 



rieaning 

Read I bus 

Do a byte read into the 

the byte 

Do a word read into the 

the low byte. 

Ur ite byte 

Urite word 

Store data in bits <23:12> of "addr" reg. 

Extended command, bits <11:8> are sub-command 

Reset the program (and the 68K and SP) 

Return low byte of read data (after cmd 2) 

Return high byte of read data (after cmd 2) 

Store low byte of write-data 

Store high byte of urite-data 

Unassigned 

FEP responses are of the form "1 7-bi ts-of-response-code 8-bi ts-of-code-dependant-data" 

Code Means 

1 Normal completetion 

2 Normal completetion with return data In <7:8> 

3 Jump response. 

4 Lbus read response 
18 RESET 

11 Command error 

12 Bus error 

13 Address error 

14 Some trap or interrupt 

The state of the bootstrap is kept in the following registers 

resp This contains the wcrd to write to the parallel port. 

response to the last command 
cmnd This contains the last command read from the parallel port. 
addr This contains the "address" from which to read, or to which to write 
data This contains the last word read, or data to write. 

The 4-way handshake works as follows: 

In the idle state both sync bits are 8, 

The Ln-2 sends a command and sets its sync bit to 1. 

The FEP sees the sync bit, performs the command, sends a response, 

and sets its sync bit to 1. 

The Lri-2 sees the response, copies the data, and clears its sync bit. 

The FEP sees the Ln-2*s sync bit clear so it clears its own and locks 

for another command. 

The Ln-2 sees the FEP's sync bit clear so it returns and ia ready 

to issue another command. 



Usual ly is the 



(defflavor expedient-paral lel-port-mixin 0) 



(def const »fep-command-responEe- 
*((1 "Normal completion") 



codes« 



(2 "Normal completion with return data") 
(3 "Jump response") 
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(18 "RESET") 

ill '"Co.Timonri error") 

( 12 "Eus erro r") _ „.. ^ „ 

{12 "Address error") 

(14 "Random trap op intcprupt") ) ) 

(defun expedient-fep-comniand (opcode ^optional (data 8) eprop-ok) 
(declape (retupn-list value status-code)) 

(let ((cmd (logjor (dpb opcode (byte 3 12.) data) 1.15,)) resp) 
;; First make sure un ACiC the last command 
(loop uhite (bit-test 1_15. (read-ppr)) 

do (wri te-ppr 8)) 
;; Nou feed it the command — first uith the valid data strobe bit off (ppeset the bus) 
(up i te-ppr (Idb (byte 15. 0) cmd)) 

(uri te-ppr cmd) ; Nou uith valid data strobe on 

;; Uait for a response, grab it, and acKnouledge it 
(loop until (bit-test 1_15. (read-ppr))) 
(setq resp (read-ppr)) 
(wri te-ppr 9) 

(loopuhile (bit-test 1_15. (read-ppr))) 
;; Analyze response for errors 
(let ((value (Idb (byte 8 0) resp)) 

(status-code (Idb (bgte 7 8) resp))) 
(unless (s status-code 7) 
(or error-ok 

(fsignal "FEP -wA error" 

(or (cadr (assq status-code »fep-command-response-codes4c) ) 
"unrecognized")))) 
(values value status-codeH)^ 

(defun expedient-fep-extended-command (opcode ^optional (data 8) error-ok) 

(expedient-fep-command 6 (dpb opcode (byte 3 8) (Idb (byte 8 8) data)) error-ok)) 

(defun expedient-fep-addr-setup (addr) 
(setq addr (idb (byte 12. 12.) addr)) 
(expedient-fep-command 5 addr)) 

(defmethod (paral tel-port :read-byte) (addr) 
(expedient-fep-addr-setup addr) 
(expedient-fep-command 1 addr)) 

;Uli I I get error from 68808 if address not even 

(defmethod (expedient-paral lel-port-mixin :read-uord) (addr) 

(expedient-fep-addr-setup addr) 

(let (dou (expedient-fep-command 2 addr))) 

(dpb (expedient-fep-extended-command 2) (byte 8 8) low))) 

(defmethod (expedient-paral lel-port-mtxin :write-byte) (addr val) 
(expedient-fep-addr-setup addr) 
(expedient-fep-extended-command 3 val) 
(expedient-fep-command 3 addr)) 

;Uill get error from 68000 if address not even 

(defmethod (expedient-paral lel-port-mixin :urite-word) (addr vat) 

(expedient-fep-addr-setup addr) 

(expedient-fep-extended-command 3 val) 

(expedient-fep-extended-comwand 4 (Idb (byte 8 8) val)) 

(expedient-fep-command 4 addr)) 

(defmethod (expedient-paral lel-port-mixin !read-lbus) (addr) 
(expedient-fep-addr-setup addr) 
(multiple-value-bind (high-6 code) (expedient-fep-command addr) 

(if (» code 4) (f error "Bad code -^ returned by expedient Ibus read. Urong prom?") code) 

(wri te-ppr 1_15.) jrequest the next 15 bite 

(loop until (bit-test 1_15. (read-ppr))) 

(setq high-6 (dpb (read-ppr) ^ol717 (ash high-S 30.))) 

(wri te-ppr 0) 

(loop until (not (bit-test 1.15. (read-ppr)))) 

(wri te-ppr 1.15.) ;request the last 15 bits. 

(loop until (bit-test 1.15. (read-ppr))) 

(setq high-6 (dpb (read-ppr) ySro0017 high-6)) 

(wri te-ppr 0) 

high-6)) 
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;;; -*- Mode: LISP; Package: LIL; Base: 8; Lowercase; t -*- 

::; These two macros corrispond to macros in the Ml code that implernent the various 

;;; requests. The protocol ts packet oriented (though the parallel-port and ethernet 

;;; implementations differ). Since the "debugging" machfne is the "master" the 

;;; protocol is not symmetric. The actual dstaits of the protocol are handled by 

;;; the protocol driver. At this level, there are tuo types of con^mands. Read commands 

;;; consist only of a "header". The FEP is expected to respond with a packet that 

;;: contains the read data. A write command sends a two segment packet. The header 

;;; segment passes the address and length of the data. The data segment follows, 

;;: The reason for this is so the header can be chccksummed separatiy, 

(defmacro fep-r-command (name args dbody body) 

(mult'ple-value-bind (opcode length array code) (crack-fep-command-args name args) 
' (progn 

.•(subst •*, array "array (nreverse code)) 

(send self * rsend-single-part-message-to-fep \array 8 , length) 

(send self ' rrecei ve-message-from-fep .opcode) 

(progl (progn ,«body) 

(send self * : f inish-recei ving-message-from-fep) ) ) ) ) 

(defmacro fep-w-command (name args ibody body) 

(ffiuitiple-value-bind (opcode length array cotie; (crack-fep-command-args name args) 
(ignore opcode) 
* (progn 

,#(subst '\ array 'array (nreverse code)) 

(send self 'rsend-message-header-to-fep '.array 8 , length) 

••body 

(send self ' : f ini sh-sending-message-to-fep) ) ) ) 
Basic-fep-access only provides direct access to the FEP address space and 
by including image-debug-mix in, makes debugging FEP programs somewhat easier. 
This flavor may be instantiated alone as a loader /debugger interface, or 
mixed with higher level flavors that use it to access the L-machine. 
This flavor implements the messages required of an "image" and hence can 
be used to receive the output of link-68k. 

(defflavor basic-fep-access (user: image-symbols-mi xin user: image-deDug-mixi nl 
(: required-methods : receive-by te-from-fep : debug)) 

:;; First define the basic read/write byte/word/ long methods 
(defmethod (basic-fep-access ;write-byte) (address byte) 
(fep-w-command write-bytes ((1 addr) (address addr)) 
(send self *: send-by te-to-fep byte))) 

(defmethod (basic-fep-access :read-bgte) (address) 
(fep-r-command read-bytes ((1 addr) (address addr)) 
(send self ' :receive-by te-from-fep) ) ) 

(defmethod (basic-fep-access ;urite-word) (address word) 
(fep-w-command write-words ((1 addr) (address addr)) 
(send self * : send-word-to-fep word))) 

(defmethod (basic-fep-access : read-word) (address) 
(fep-r-command read-words ((1 addr) (address addr)) 
(send self * :receive-word-from-fep) ) ) 

(defmethod (basic-fep-access :read-long) (addr) 
(let ((hi (send self *: read-word addr)) 

do (send self *: read-word (+ addr 2)))) 
(logior (ash hi IS.) lo))) 

(defmethod (basic-fep-access : write- long) (addr long) 
(send self 'twrite-word addr (Idb ;;^o2028 long)) 
(send self •:write-word (+ addr 2) (Idb )i?o0023 long))) 

(defmethod (basic-fep-access :goto) (address) 
(send self * :abort-to-fep) 



4,887,235 
1057 _ 1058 

<send self * : send-uord-to-fep (fep-op-nuflibep-from-name 'goto)) 
<send self ' :send-addr-to-fep address) 
(send self * : f inish-sending-message-to-fep) ) 

;;; Now define the block-mode read/write byte/word methods 
(defmethod (basic-fep-access :wri te-bytes) (arry index addr nbytes) 
(fep-w-cotnmand wri te-bytes ((nbytes addr) (addr addr)) 
(send self ': send-by te-array-to-fcp arry index nbytes))) 

(defmethod (basic-fep-access rread-bytes) (arry index addr nbytes) 
(fep-r-command read-bytes ((nbytes addr) (addr addr)) 

(send self ' :recei ve-byte-array-from-fep arry index nbytes))) 

(defmethod (basic-fep-access :wri te-words) (arry index addr nuds) 
(let* ((nbytes (+ nwds nwds) ) 

(barray (make-array (+ nbytes \ndex mdex) ' : type 'art-Sb ' :disp(aced-to arry))> 
(fep-w-command uri te-words ((nwds addr) (addr addr)) 

(send self * rsend-byte-array-to-fep barray (* index 2) nbytes)))) 

(defmethod (basic-fep-access :read-words) (arry index addr nwds) 
(let* ((nbytes (+ nwds nwds)) 

(barray (make-array nbytes ^type *art-8b 'tdisplaced-to arry))) 
(fep-p-command read-words ((nwds addr) (addr addr)) 

(send self ' :recei ve-byte-array-from-fep barray (« index 2) nbytes)))) 

(defmethod (basic-fep-access :read-fep-program-version) 
tfep-r-command read-version {) 

(let ((prom-p (send self ' :recei ve-word-from-fep) ) 

(version (send self 'treceivc-tong-from-fep))) 
(list prom-p ver s i on) ) ))_ 
This is a copy of the omn i byte- i «age~"dibugger . The d i f f erences are that 

ITri I*? r*^ '!? '^^''^ '" * different place, and that the traps are trap numbers 
and not trap addresses. 

(defmethod (basic-fep-access :why) (^optional irg ffo^QZZZd) (sb ;^o48B0e3) ) 
(format t "-r?^") 
(let* ((fp (send self ':read-long (+ rg 70))) 

(sp (send self 'tread-long (+ rg 74))) 

(trapn (send self 'tread-word (+ rg 108)))) 

(loop for reg in * (D0 D4 A0 A4) 
wi th loc « rg 

do (format t "*^ *,A «" peg) 
(loop repeat 4 

do (format t -*130- (send self 'tread-long loc)) 
(incf loc 4))) ^ 

(format t "-2«Sp « •O, Fp . ^, " gp fp) 
(cond ((or (. trapn 2) (- trapn 3)) 

(if <- trapn 2) (format t -Bus error") (format t "Address error")) 
(format -^Trap block Fen . ^, Addr . ^. Ir . ^, Sts ! i Pc..A<.^)- 
(send self 'tread-word sp) mj, re - ^Ai^^} 

(send self 'tread- long (+ sp 2)) ; access addr 
(send self 'tread-word (+ sp G)) ;ir 
(send self 'tread-word (+ sp 8)) jsts 
(send self ' t symbol rc-address 

(send self 'tread- long U sp 10.)) 200) 
(send self 'tread-long (+ sp :0. ) ) ) -pc 

iiZ\rtl'sJ.\^ is trapn 11.,, '^""""^ '"' ' "'' "' *'-'' "" '^^^^ 

(format t "^A" (nth (- trapn 4) 

•("Illegal insn" "Zero div" "CHIC tnsn" "trapv insn" 
,, , , . .T "^^''' violation" "Trace" "op 1010 trap" "op 1111 trao"))) 
(format t "^Trap data Sts - -vQ, Pc - -vA(.-^)- h op mi irap ))} 

(send self 'tread-word sp) 

(send self ': symbol ic-address (send self 'tread-long (+ sp 2)) 200) 
(send self 'tread- long (+ sp 2))) 
(incf sp G.)) 
((• trapn 0) 

(Format t "No trap taken...")) 
(t (format t "Unknown trap - -vQ. " trapn))) 
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;; Loop over an frames 
Ooop whi te (< sp st3) 

do (if (or (< fp sp) U fp sb) ) 

(return (format t "-dScreued up stack . . . Sp - ^, Fp « -^, Sb « -^" 
ep fp sb) )} 
(let* ({rts (send self 'iread-long (+ fp 4))) 
(nfp (send self ':read-iong f p) ) ) 
;; Try to print out the name of the function this frame belongs to, 
(if (or (and (> rts iJo4£04) l< rts UolQBBd) } 

(and /> rts ffo^Z^ZZ^) (< rts ^oLCaaoaa))) 
(format t "-^Z&Frame for fen -*As" 

(send self *: symbol ic-address 

(send self 'tread-long (- rts 4)) 222)) 
(format t "A'Z&Frame for unknown function:")) 
;; Loop over alt word in the frame 
( loop unti I (a sp fp) 

for wd » (send self *!read-uord sp) 
for Ig • (send self 'tread- long sp) 
do (format t •''^'v2X-wl20: ^70" sp wd) 
(if (< sp (- fp 2)) 

(format t " -120" Ig)) 
(incf sp 2)) 

;; Now print the fp £ rts linkage words 
(format t "-vfi-llXNfp: -^" nfp) 

(format t "^^llXRts: ^" (send self ': symbol ic-address rts 283)) 

(setq sp (+ fp 8) 
fp nfp))) 
(format t "-5"))) 

;;; An instance of a saart-fep knows how to talk to a fep program that can access 
;;; most of the L-Hachine registers and datapaths directly. 

(def f lavor smart-fep-mixin (basic-fep-access) ) 

(defmethod (smart-fep-mixin :write-lbus) (addr wcrd) 
(fep-w-command write- 1 bus ((addr long)) 
(send self * : send-long-to-fep word) 
(send self ': send-by te-to-fep (Idb ^o40B4 word)))) 

(defmethod (smart-fep-mixin :read-lbus) (addr) 
(fep-r-command read-lbus ((addr long)) 

(let {(wd (send self ' :receive-long-from-fep) ) ) 

(dpb (send self ' jreceive-byte-from-fep) UoUQQC^ wd) ) ) ) 

(defmethod (ewart-fep-mixin :wr i te-lbus-and-ecc) (addr word) 
(fep-u-command wri te-lbus-and-ccc ((addr long)) 
(send self * :send- long-to-fep word) 
(send self *:send-word-to-fep (idb ^d4614 word)))) 

(defmethod (smart-fep-wixin :read-Ibu5-and-ecc) (addr) 
(fcp-r-command read-lbus-and-ecc ((addr long)) 
(let ((wd (send self ' trccelve- ?ong-from-fep)) ) 

(dpb (send self ' treceive-word-from-fep) #o4814 ud)))) 

(defmethod (smart-fep-mixin :wr i te-Ibus-block) (arry index addr nwords) 
(if (oddp nwords) (ferror nil "Odd word count to write-lmem wont work")) 
(fep-w-command wr i te-i bus-block ((nwords addr) (addr addr)) 
(loop for i from index below (+ nwords index) by 2 
for wdl • (aref arry i) 
for wd2 « (aref arry (1+ i)) 
do (send self ': send-long-to-fep wdl) 

(send self ': send-by te-to-fep (dpb (logand wd2 tfoll) iSfo8404 (ash wdl -32.))) 
(send self ': send-long-to-fep (ash wd2 -4.))))) 

(defmethod (smart-fep-mixtn sread-lbus-block) (arry index addr nwords) 
(if (oddp nwpros) (ferror nil "odd word count")) 
(fcp-r-coirma'nd read- 1 bus-block ((nwords addr) (addr addr)) 
(loop for i from Index below (+ nwords index) by 2 
for tl - (send self ' :recei ve-long-from-fep) 
for tb - (send self * rrecei ve-byte-from-fep) 
do (setf (aref arry i) (dpb tb <ro4034 tl)) 

(setq tl (send self ' rrecei ve-long-from-fep) ) 

(setf (aref arry (1+ i)) (dpb (Ish tb -4) #o8804 (ash tl 4)))))) 
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;;; Support for Load a uorld toad 

(defmethod (smart-fep-mix in Mbu9-wr 1 te-from-stream) (nuords address stream) 
(if ibit-test nwords 3) (terror nit "Bad word count."}) 
(fep'-u-conmand wri te- tbus-block ( (nuords addrJ (address addr)) 
(loop uith uds-left - (// (* nwords 9) 4) 
until (zerop wds-ieft) 

do (multiple-vatue-bind (buf index wd-cnt) (send ctreara * tget-input-buf fer) 
(fet« ((length (« (+ index ud-cnt) 2)) 

(d-array (cond ((not (si : array- tndexed-p buf)) 
(make-array length 

*:type 'art-Sb 
':disptaced-to buf)) 
(t 
(wake-array length 

':type 'art-Sb 

•:dispfaced-to (si :array-indirect-to buf) 
• : d i sp I aced- 1 ndex-of f se t 
(* 2 (sirarray-index-offset buf)))))) 
(uds-this-whack (min uds-left ud-cnt)>) 
;; (format t "^w^ds this whack « mJ. " wds-this-whack) 
(send self ': send-by te-array-to-fcp 

d-array (» index 2) (« 2 uds-this-whack)) 
(send stream ' :advance-input-buf fer (+ index wds-thi s-whack) ) 
(decf wds-left wds-th i s-whack) )))) ) 

(dec I are (spec i a I I cons: *cached-page-s i ze*) ) 

(defconst bytes-per-page (// (» 9 lcons:»cached-page-si2e«) 2)) 

(defconst uords-per-page (// bytes-per-page 2)) 

(defconst *f mem-read-byte-array* (make-array bytes-per-page 

•:type 'art-Sb)) 
(defconst «Imem-read-word-array« (make-array words-per-page 

': type *:art-16b 

* : d i sp I aced-to « I mem-read-byte-array* 

•: leader-list * (8))) 

(defnethod (smart-fep-mixin :ur i te-lbus-page-to-stream) (page stream) 
(fep-r-command read- 1 bus-block ( ( lcons:*cached-page-si2e* addr) 
((* page !cons:*cached-page-5ize*) addr)) 
(send self ' :receive-byte-array-from-fep 

« I mem-read-byte-array* 8 bytes-per-page)) 
(self (f ! I l-pointer *(triem-rfcad-uord-array*> uords-per-page) 
(funcall stream ': string-out *l»em-re3d-word-array*) ) 
(defmethod (5mart-fep--mixin :read-f ixnums) (address wd-array) 
(let* ((nwords (array-act ive- length ud-array)) 
(nnums (// nwords 2)) 
(nbytes (* nnums 4)) 

(barray (make-array nbytes ' : type 'art-8b ' :dicplaced-to wd-array))) 
(fep-r-cowmand read-f ixnums ((nnums word) (address addr)) 
(send self ' :recei ve-byte-array-from-fep 
barray 8 nbytes)) 
ud-array)) 

(defmethod (smart-fep-mixin :wri te-f ixnums) (address wd-array) 
(tet* ((nwords (array-act ive- length wd-array)) 
(nnums (// nwords 2)) 
(nbytes (* nnums 4)) 

(barray (make-array nbytes ' : type 'art-8b ' :disp!aced-to wd-array))) 
; (If (oddp nwords) (ferror ni ) "Fixnum packet not an integral number of words lonq**)) 
itep-H-com!rand wr i te-f ixnums ((nnums word) (address addr)) 

isend self *: send-by te-arroy barray 8 nbytes)) 
wd-array) ) 

; (defun zero-lbus-block (addr leng) 

: (if (bit-test leng 1) (Ferror nil "Zero-lbus-bfock must be given an even U of words ")) 

; (ut th-new-protocol 

; (fep-w-command 138 ((leng addr) (addr addr)) 

; (loop repeat (ash leng -1) 

: do (setq *checksum* (sys:Xsend-bytes «paral lel-port-address* 

• «checksum* 9 



4,887,235 
1063 1064 

•#. (make-array 9 * : type ':apt-Sb) 8)))))) 

; bar f 

(dafvar ones-array (make-array 3 'ztype ':art-8tj)) 

(si ; f r I l-array cnes-array 3 -1) 

(defun ones- Ibus-blcck faddr Jeng) 

(if (bit-test leng 1) (Ferror ni i "Ones- i bus-block must be given an even # of uords.")) 
(ui th-neu-protoco I 

(fep-u-command 130 (Cleng addr) (addr addr}) 
(locp repeat (ash leng -1) 

do (setq »check3um« (sysiXsend-bytes *paraMel-poPt-address* 

♦checksum* 9 onee-array 2)))))) 
(def method (smapt-fep-aixin :wr i te-CBcm-ud) (wd) 
(fep-u-conmand up t te-cnem-ud (} 
(loop pepeat 14. 

fop ppss upfpom ^00010 by ffolBQQ 

do (send self ': send-by te-to-fcp (Idb ppss wd))))) 

(defmethod (smapt-fep-«ixin :read-uir) 
(fep-p-command read-uip 
(loop repeat 14, 

ui th rcsuf t ■ 

fop ppss upfpom tio2212 by #ol000 

do (setq pesult (dpb (send self ': receive-by te-from-fep) ppss pcsult)) 

finally (petupn resul t) ) ) ) 

(defmethod (smart-fep-mixin tupite-uir) (ud) 
(fep-w-command wpite-uir 
(loop repeat 14. 

for ppss upfrom ;!fo0010 by tfol000 

do (send self * isend-byte-to-fep (Idb ppss wd) ) ) ) ) 

(defmethod (smart-fep-wrxtn :urite-c«em) (addr ud) 
(fep-w-command urite-cmem ((1 word) (addr word)) 
(loop repeat 14. 

for ppss upfpom #00010 by #ol000 

do (send self ' :send-byte-to-fep (Idb ppss ud)))>) 

(defmethod (smapt-fep-mixin :upi te-cmem-and-papi ty) (addr wd) 
(fep-u-cotnmand up i te-cmem-and-papi ty ( (1 wopd) (addp uopd) ) 
(loop pepeat 14, 

fop ppss upfpom ;tfo0010 by #ol000 

do (send self * .-send-bytc-to-fep (Idb ppss ud))))) 

(defmethod (smart-fep-mixin :upi te-cmem-block) (apry index start nuds) 
(fep-w-command ur ite-cmem ((nuds uord) (stapt word)) 
(loop for i from index belou (+ index nuds) 
for ud - (aref arry i) 
do (loop repeat 14. 

for ppss upfrom #00810 by #ol000 

do (send self ' : send-byte-to-fep (Idb ppss ud) ) ) ) ) ) 

(defmethod (smart-fep-mixin :read-cmem) (addr) 
(fep-r-command read-cmem ((1 uord) (addp woPd) ) 
(loop pepeat -14. 

ui th pesul t ■ 

fop ppss upfpom #00010 by #ol000 

do (setq pesult (dpb (send self ' ipcceive-byte-from-fep) ppss result)) 

finally (return resul t) ) )) 

(defmethod (smart-fep-mixin :read-cmem-block) (arry index start nuds) 
(fep-r-command read-cmem ((nuds word) (start word)) 
(loop for i from index belou ('+ index nuds) 
do (loop repeat 14, 

ui th pesul t ■ 

fop ppss upfPom #00010 by #ol000 

do (setq result (dpb (send self *:receive-byte-from-fep) ppss result)) 

finally (setf (aref arry i) result))))) 

(defmethod (smart-fep-mixin :upite-amem) (addP val) 
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(fep-w-command upite-amem ({1 uopd) (addr uord)) 
i loop repeat 5 

for ppss upfpom #00018 by ttol22Q 

do (send self * :8end-byte-to-fep (Idb ppss val))))) 

(deffnethod (smart-fep-mixin jwr i te-amem-block) (arrg index addr nuds) 
(fep-w-command urite-amcfn ( (nwds uord) (addr word)) 
(loop for i from index below (+ index nwds) 
for val - (aref arry i) 
do (loop repeat B 

for ppss upfrom #00310 by #ol000 

do (send self ': send-by te-to-fep (Idb ppss val)))))) 
(defmethod (smart-fep-mlxin :read-amem) (addr) 
(fcp-r-command read-amcni ((1 word) (addr word)) 
(loop repeat 5 

wi th resul t • 8 

for ppss upfrom #o8818 by #ol800 

do (setq result (dpb (tend self ' :receive-byte-from-fep) ppss result)) 

finally (return result)))) 

(defrrethod (smart-fcp-mtxtn :read-ameffl-and-par t ty) (addr) 
(fep-r-command read-amem-and-par i ty ((1 word) (addr word)) 
(loop repeat 5 

wi th resui t « 

for ppss upfrom #00018 by #ol000 

do (setq result (dpb (send self ' :receive-byte-from-fep) ppss result)) 

finally (return resul t)) )) 

(defmethod (smart-fep-mixin :read-amem-block) (arry index addr nwds) 
(fep-r-command read-amem ((nwds word) (addr word)) 
(loop for i from index below (+ index nuds) 
do (loop repeat 5 

wi th resul t - 8 

for ppss upfrom #00018 by #ol800 

do (setq result (dpb (send self ' :receive-byte-from-fep) ppss result)) 

finally i«etf (aref arry i) result))))) 

(def method ismart-fep-mixin :wr i te-bmem) (addr val) • 
(fep-w-command write-bmem ((1 word) (addr word)) 
(loop repeat 5 

for ppss upfrom #00010 by #ol000 

do (send self ': send-by te-to-fep (Idb ppss val))))) 

(defmethod (smart-fep-mixin : wr i te-btnem-block) (arry index addr nuds) 
(fep-w-command write-bmem ((nwds word) (addr word)) 
(loop for i from index below (+ index nwds) 
for val m (aref arry i) 
do (loop repeat 5 

for ppss upfrom #00010 by #ol800 

do (send self ': send-by te-to-fep (Idb ppss val)))))) 

(defmethod (smart-fep-mixin :read-bmem) (addr) 
(fcp-r-command read-bmem (d word) (addr word)) 
(loop repeat 5 

wi th result • 

for ppss upfrom #00010 by #ol000 

do (setq result (dpb (send self ' :recet ve-byte-from-fep) ppss result)) 

finally (return result)))) 

(defmethod (smart-fep-mixin :read-bmem-and-parf ty) (addr) 
(fep-r-command read-bmem-and-par i ty ((1 word) (addr word)) 
(loop repeat 5 

wi th result « 

for ppss upfrom #00010 by #ol080 

do (setq result (dpb (send self ' :recei ve-byte-from-fcp) ppss result)) 

finally (return result)))) 

(defmethod (smart-fep-mixin :read-bmem-block) (arry index addr nwds) 
(fep-r-command read-bmem ((nwds word) (addr word)) 
(loop for i from index below (+ index nwds) 
do (loop repeat 5 
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wt th resul t - 9 

for ppss upfront #00819 by #ol899 

do (setq result (dpb (send self ' sreceive-byte-from-fep) ppss result)) 

finally (setf (aref arry t) result))))) 

(defmethod (smart-fep-mixin :wr i te-type-map) (addr val) 

(fep-w-command tjr i te- type-map ((1 word) (addr uord) ) (send self * : send-byte-to-fep val))) 

(defmethod (smart-fep-fnixin :wr i te-type-map-and-par i ty) (addr val) 
(fep-u-command wr i te-type-map-and-par i ty ( (1 word) (addr word)) 
(send self ' : send-bute-to-feo va!))) 
(defmethod (smart-fep-wixin ;wr i te-type-map-block) (arry index addr nwds) 
(fep-w-command wri te-type-nap ((nwds word) (addr word)) 
(send self ': send-by te-array-to-fep arry index nwds))) 

(defmethod (swart-fep-mixin : read- type-map) (addr) 

(fep-r-command read-type-map ((1 word) (addr wordU (send self ' :receive-byte-from-fep)) ) 

(defmethod (smart-fep-mixin : read- type-map-block) (arry index addr nu.ds) 
(fep-r-command read- type-map ((nwds word) (addr word)) 

(send self *; receive-by te-array-from-fep arry index nwds))) 

(defmethod (smart-fep-mixin !wr i te-gc-map) (addr val) 

(fep-w-command wr i te-gc-»ap ((1 word) (addr word)) (send self ': send-by te-to-fep val))) 

(defmethod (smart-fep-mixin : wr t te-gc-map-and-par i ty) (addr val) 
(fep-w-command wri te-gc-map-and-par i ty ((1 word) (addr word)) 
(send self ': send-by te-to-fep val))) 

(defmethod (smart-fep-mixin :read-gc-»ap) (addr) 

(fep-r-command read-gc-map (U word) (addr word)) (send self * ;receive-byte-from-fep) ) ) 

(defmethod (smart-fep-mixin :write-cpc) (val) 

(fep-w-command write-cpc (send self ':8end-long-to-fcp vat))) 

(defmethod (smart-fep-mixin iread^c;3c) 

(fep-r-command read-cpc (send self ': receive- I ong-from-fep) ) ) 

(defmethod (smart-fep-mixin ;write-npc) (val) 

(fep-w-command write-npc (send self ' :send-long-to-fep val))) 

(defmethod (smart-fep-mixin tread-npc) 

(fep-r-command read-npc (send self ': receive- I ong-from-fcp) ) ) 

(defmethod (smart-fep-mixin :wr i te-byte-r) (val) 

(fep-w-command wri te-byte-r (send self *: send-by te-to-fep val))) 

(defmethod (smart-fep-mixin :read-byte-r) 

(fep-r-command read-byte-r (send self * :receive-byte-from-fep) ) ) 

(defmethod (smart-fep-mixin :wr t te-byte-s) (vat) 

(fep-w-command write-byte-s (send self ' t send-byte-to-fep val))) 

(defmethod (smart-fep-mixin : read-by te-s) 

(fep-r-command read-tiyte-s (send self ' treceive-byte-froa-fep) } ) 

(def-*ethod (smart-fep-mixm swr i te-stack-pointer) (val) 

(fep-w-command wr i te-stack-pointer (send self * :send-long-to-fep vat))) 

(defmethod (smart-fep-mixin rread-stack-pointer) 

(fep-r-command read-stack-pointer (} (send self * :receive-long-from-fep) ) ) 

(defmethod (smart-fep-mixin :wr i te- frame-pointer) (val ) 

(fep-w-command wri te-frame-po inter (send self ': send- long- to-fep val))) 

(defmethod (smart-fep-mixin :read-frame-pointer) 

(fep-r-command read-frame-pointcr (send self ' :recei ve-long-from-fep) ) ) 

(defmethod (smart-fep-mixin :write-xbas) (val) 

(fep-w-command write-xbas (send self *: send- long- to-fep val))) 
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(defmethod (smart-fep-mixin tread-Kbas) 

(fep-r-command read-xbas (send self * :receive-long-from-fep) ) ) 

(defDelhod (smart-fep-mtxin :read-obus) 

(fep-r-command read-obus (send self ' :recei ve-nbytes-fpom-fep B) ) ) 

(defmethod (smart-fcp-mixin :upite-md) (val) 

(fep-w-cofnmand write-md (send self * :8end-nbytcs-to-fep B val))) 

(dfeftnothod (snart-fep-mixin :read-md) 

{ fep-r-command reacJ-md (send self * :recei ve-nbytes-from-fep S) ) ) 



(defnethod (sfflart-fep-aixrn :ur ite-vma) (val) 

(fcp-u--com«and wrtte-v«a (send self * : send-long-to-fep val))) 

(defmethod (smart-fep-«ixin :read-vma) 

(fep-r-coRimand read-v»a (send self ': receive- 1 ong-from-fep) ) ) 

(defmethod (smart-fep-»ixin :urite-pc) (val) 

(fep-u-command urite-pc (send self ': send- long- to- fep val)) I 

(defmethod (smart-fep-*ixin tread-pc) 

(fep-r-coirmand pead-pc (send self ' iPecei ve-long-fpom-fep) ) ) 

(defmethod (sitapt-fep-aixin :pead-asn) 

(fep-p-command pcad-asn (send self ' :PBceive-long-fpom-fep) ) ) 

(defmethod (smart-fep-«ixm tpead-cpocks) (addp) 

(fep-p-comaand pead-cpocKs ((addp long)) (send self * :peceive-long-fpom-fep) ) ) 

(defmethod (smapt-fcp-nixtn :pcset-lbus) (fcp-u-co«mand peset-lbus nil)) 
(defmethod (sraapt-fep-aixin :pcset-3BS8) (fep-w-command peset-3600 nil)) 

(defmethod (smapt-fep-mixin :pead-tbu8-boapd-id) (boapd loc) 
(fep-r-conmand pead-!bus-boapd-(d ((board byte) (loc byte)) 
(send self ':peceivc-byte-fpom-fep) > ) 

(defmethod (smap t-f ep-»ixm jread-fep-board-id) (loc) 
(fep-r-command pead-fep-boapd-id (doc byte)) 
(send self ' :PCceive-byte-fpom-fep) ) ) 

(defmethod (smapt-fep-mixin :pead-fep-paddle- Id) (loc) 
(fep-p-command pead-fep-p3ddle-id ((loc byte)) 
(send self * zpecci ve-by te-fpom-fep) ) ) 

(defmethod (smcpt-fep-nixin !pead-opc) (n) 

(fep-p-command pead-opc ((n wopd)) (send self ' ipccetve-uopd-fpom-fep) ) ) 

(defmethod (smapt-fep-mixin tpead-ctos) 

(fep-p-command pead-ctos (send seJf * :peceive-long-fpom-fep) )) 

(defmethod (smapt-fep-mixin :up i te-cup-task) (task) 

(fep-u-command wpi te-cup-task () (send self *:send-wopd-to-fep task))) 

(defmethod (smart-fep-mtxin :pead-cup-task) 

(fep-p-command read-cur-task (send self ' :pecei ve-wopd-fpom-fcp) ) ) 

(defmethod (smapt-fep-mixin :wpite-cstk) (addp val) 

(fep-w-command MPite-cstk ((addr uopd)) (send self ' tsend-wopd-to-fep val))) 

(defmethod (snart-fep-mixin :wpi te-cstk-and-papi ty) (addp vat) 
(fep-u-command wpi te-cstk-and-pap i ty ((addp woPd)) (send self '.'send-wopd-to-fep val))) 

(defmethod (smapt-fep-mixin :read-cstk) (addp) 

(fep-p-command pead-cstk Haddr word)) (send self 'trecei ve-long-fpom-fep))) 

(defnethod (smapt-fep-mixin :wpite-csp) (csp) 

(fep-w-conmand wpite-csp (send self ': send- long- to- fep csp))) 

(defmethod (smapt-fep-mixin rpead-csp) 

(fep-p-comntand pead-csp (send self * :peceive-long-fpom-fep) ) ) 
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(defmethod (smapt-fep-mixin : start-machine) 
(fep-u-command start-machine ())) 

(defne^thod (smart-f ep-mixi n ; step-machine) (ntimes) 
(fep-w-command step-nachine ((ntimes word)))) 

(defmethod (snart-fep-mixin : stop-machine) 
(fep-w-command s top-mach i ne ( ) ) ) 

(defmethod (smar t-fep-mixin rrestore-state) 
(fep-w-cofflmand restore-state ())) 

(defmethod (smart-fep-mixin :di scard-statc) 
(fep-u-command discard-state ())) 

(defmethod (smart-fep-mixin :ur i te-comm-var) (var value) 
(fep-w-ccmmand wr i te-comm-var ((var uord) (value long)))) 

(defmethod (smart-fep-mixin :read-comm-var) (var) 

[fep-r-comm and read-co mm-var {(var^ord)) (send self * :recei ve-!ong-from-fep) ) ) 

;;; Support for the kludge. 

(defmethod (smart-fep-mixin :k/udge-query-status) (&aux stoppedp chars-avai lablep 

norma / -char-reques t-count 
mini -char-request-count) 
(fep-r-command kludge-status 

(setq stoppedp (not (zerop (send self ' treceive-bytc-from-fep)) ) 

chars-avai lablep (not (zerop (send self ':recei ve-byte-from-fep) ) ) 
norma I -char-request-count (send self ' :receive-word-frcm-fep) 
wini-char-request-count (send self ' : recei ve-word-from-f ep) ) ) 
(setq stoppedp ( Icons: machine-stopped-p) ) -for nou... 
(values stoppedp chars-avai lablep normat-char-rcquest-count nini-char-request-count) ) 

;;; This reads n 32 bits numbers from the FEP 

(defmethod (smart-fep-mixin :kludge-receive- input-characters) (arry) 
(setf (fill-pointer arry) 8) ;no chars to start with 

{ f ep-r-cojnmand k 1 udge-rece i ve-chars 

(loop repeat (send setf ' rrecei ve-word-from-fep) 

do (array-push arry (send self *: recei ve-fong-from-f ep) ))) ) 

;:; This sends a single 32 bit number to the fep 
(defmethod (smart-fep-mixin :kludge-send-kludge-char> ichar) 
(fep-w-command send-k ludge-char ((1 word)) 
(send self ': send- long- to- fep char))) 

;;; This sends n 32 bit longs. Array is ART-Q. 

(defmethod (smart-fep-mixin :kludge-send-k!udge-«ini-longsi larry offset n(ongs} 
(fep-u-command send-k ludge-mini- longs ((n longs word)) 
(loop for i from offset below (+ offset niongs) 

do (send self ' : send-long-to-fep (aref arry i))))) 

;;: This eends 16 bit words, barray is ART-8B. It reads (» nwords 2) bytes 
;; ; from the array. 

(defmethod (smart-fep-mixin .'kludge-send-kludge-wfni-words) (barray offset nwords) 
(fep-w-command send-k I udge-tnini -words ((nwords word)) 

(send self * : send-byte-array-to-fep barray offset (« nwords 2)))) 

;;; This sends 8 bit bytes. 

(defmethod (smart-fep-mixin :kludge-send-kludge-«ini-bytes) (barray offset nbytes) 
(fep-w-command send-k ludge-«ini-bytes ((nbytes word)) 

(send self ': send-by te-array-to-fep barray offset nbytes))) 
;:; A parallel port 

(defflavor Parallet-port-ii»age (expedient-paral lel-port-mixin smart-fep-mixin 

basic-fep-access parallel-port)) 
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::;-»- Mode: Lil; Package:Lil: 6ase:8.: Louercase: T -»- 



1074 



(include "Tyoes-and-macros") 

(include "fsm.EXT" "di sk-rau.EXT" "disk.EXT" "fep-ut i Is.EXT" "machine. EXT") 

(cxternai (fep-disk-select-uni t string) ((unit word))) ;tn hsb 

(external (inicrocode-read-di sk-to-vma string) ((uni t word) (dpn long) (page-count long) 

(start ing-vma long))) 

(def ine-sgsconstants 



*«vna-equals-pina 
ISconf ig-board-type 
Xconf i g-memory-board 
Xconf ig-io-board 
Xconf t g-no-board 
XSconf i g- f i rs t-page 
XXconf i g- ! as t-page 
) 



;pp8s in pointer 

sppss in ID prom 

; va I ue 

t va I ue 

: value 

;ppss 

;ppss 



(def ine-sysdfl-atommacros 

(nicrocode-constants 
(ni I Xquote-ni I ) 
(t Xquote-t) 

) 

(a-memory-var i ab t es 
tu i red-v i r tua I -addrcss-h i gh 
Xw i red-phys i ca { -address- I om 
Xu i red-phys i ca i -addr ess-h i gh 
) 



( f ep-ccmmun i cat i on-ar ea 
load-map-size 
I oad-map-address 
I oad-map-dpn-address 

swap-map-size 

swap-map-address 

swap-map-dpn-address 

bad-memory-pages-s i ze 
bad-memory-pages-address 



) 



;0 for preload, n-load for instaboot 

;at top mem - 1 page 

;9 for preload, entries for instaboot 

$8et to 1 for now 

; points to table with BQZQZ, for now 

;points to table with Gh000, for now 

;8et to for now 

;points to table of Ccount,ppn3 



(defvar minhibi t-veri fy-sparse-load« boole false) 
(defun init-toad-world 

(setq initial-map-array (make-nuM -pointer load-map-array)) 

(setq load-map-array (make-nul I-pointcr load-map-array)) 

(setq «inhibi t-ver i fy-sparse-load* false) 

) 

(defun (load-world string) ((unit word) 

(f i lename string) 
(insta-boot boote) 
(maps-after-initial boole) 
(use-ffiicrocode-for-di 8k- loading boole) ) 
(let ((error-message NULL-string) 
(fs NULL-fi te-stream)) 
(setq boot-status (cond ((not (null (setq error-message (fep-disk-select-uni t unit)))) 

bs-wor Id-unt t-se lect-error) 

((null (setq fs (open-file filename d»-3Gbit dd-read))) 
(setq error-message "No file stream what-so-ever. ") 
bs-wor I d-open-error ) 
((not (null (progn (swapf (error-message fs) error-message) 

error-message))) 
bs-wor t d-open-error } 
((not (null (setq error-message 
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(ioad-uorld-fpom-f i le-stpcam 

fs insta-boot maps-after-initial 
use-in i crocode-f op-d i sk- 1 oad i ng) ) ) ) 
boot-status) 
(T ( load-wop Id-epi logue) 

(setq eppop-Hiessage "Load uopid pequeat complete.') 
bs-success) ) ) 
(unless (nul I f s) (close-f i (e-stpeam f s) ) 
eppor-message) ) 

(defun t load-wop Id-fpom-f i le-stpeam stping) ((fs file-stpeam) 

(insta-boot boole) 
(naps-aftcp-ini tial boole) 
(use-disk-micpocode boole)) 
(Iet» ((mic-majop-vepsion (di sk-tyi-3S-data fs)) 
(load-uopld-vepsion (di sk-tyi-3G-data fs)) 
(n-spapsc (disk-tyi-3G-data fs)) 
(n-initial (di sk- tyi -3G-data fs)) 
(n-load (disk-tyi-3S-data fs)) 
(eppop-wessage NULL-stping)) 
(setq boot-status bs-uop Id-f i le-vepi fy-eppop) ;wi M get reset if changes 
(cond ((not (< n-sparse £800.)) "Unbelievable number of spapse entpies.") 
((not (< n-initiai 200.)) "UnbeMevable numbep of initial entpies.") 
((not (< n-ioad 1000.)) "UnbeMevabie numbep of toad entPies.") 
((not (null (setq eppop -message (toad-spapse fs n-spapse)))) erpop-wessage) 
((not (null (setq erpOP-Biessage (get- load-maps fs n-initial n-load)))) 
eppop-nessage) 
((not (null (setq eppop-message 

( toad-fpom-map fs ini tial-«ap-appay 

n-initial use-di sk-micpocode 
"Eppop loading initial system.")))) 
eppop-message) 
((and (not insta-boot) 

(not (null (setq cprop-message 

( toad-fpom-map fs load-map-appay 

n-load use-disk-micpocode 
'Error ppe loading load. "))))) 
eppop -message) 

((not (null (setq epPOP-message (setup- load-maps «aps-af tep-ini t iai 

load-map-appay 



eppor-message) 
(T NULL-string)))) 



n- I oad 
insta-boot)))) 



(defun (load-Epapse stping) life fi/tf-stream) (n-sparae long)) 
(let {(otd-f i lepos (pead-fi iepos fs dm-3Gbtt))) 
(loop pepeat n-spapse 

as (vma long) - (di sk-ty i-36-data fs) 
as (data Ibus-uopd) - (disk-tyi-3G fs) 
do (wi th-spy-bus-gpabbed (up ite-vmem vma data))) 
(unless *inhibi t-vep i fy-spapse-lo3d« 

(set-f i iepos-and-mode fs old-filepos dm-3Gbit) 
(loop pepeat n-spapse 

as (vma long) « (di sk-tyi-3G-data fs) 

as (data Ibus-uopd) • (disk-tyi-3G fs) 

as (expected Ibus-uopd) ■ (wi th-spy-bus-gpabbed (pcad-vmem vma)) 

uhen (op im (data data) (data expected)) 

(f (ecc+high data) (togand ftol7 (ecc+high expected)))) 
petupH "Spapse load compape eppop." 
finally (retupn NULL-stping) )) 
)) 

(defun (a I locate- load-map load-map-appay) ((n-entpies long)) 

(coepce load-map-appay (fsm-al locate (* (word n-entpies) (type-size load-map-entry))))) 

(dffun re tupn- load-map ( (Ima load-map-appay)) 
(fsm-fpee (coePce long Ima))) 

(defun (get- load-naps string) ((fs file-stpeam) (n-initial long) (n-load long)) 
(unless (nul I ini t iai-map-array) 
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(return- load-map Int t la I -map-array) 

(sctq ini tial -map-array (maKe-nu I 1 -pointer Joad-map-array) ) ) 
(unless (null load-map-array) 
(return- I oad-map I oad-map-array) 

(setq load-map-array (make-nu! 1 -pointer load-map-arrayH ) 
(let ((error-message NULL-str ing) ) 
(setq error-message 

(cond ((null (setq tni t iai-map-array (at locate- load-map n-ini tial U ) 
"Couldn't allocate initial map array.") 
((not (null (setq error-message 

(f i n-in- toad-map fs initial-map-array n-ini t iai ) ) ) ) 
error-message) 

((null (setq load-map-array (at locate- /oad-map n- load) ) ) 
"Couldn't allocate load map array. "J 
((not (null (setq error-message 

(f i I l-in-load-map fs load-map-array n-Ioad)))) 
error-message) 
(T NULL-string))) 
error-message)) 

(defun (fi I I- in- load-map string) ((fs file-stream) (Ima load-map-array) (n-entries long)) 
(loop for (i long) upfrom 8 below n-entrics 

as (starting-vma long) « (disk-tyt-36-data fs) 

as (number -of-words long) - (disX-ty t-3B-data fs) 

as (file-page-number long) - (di sk-tyi-36-data fs) 

as (disk-page-nu^iber long) • (dpn (d4c-for-b!ock fs file-page-number)) 

if (bit-test tfo377 starting-vma) 

return "Some starting VriA is not on a page boundary," 

if (bit-test Uo211 numbcr-of-words) 

return "Some number of load words is not a multiple of one page." 

if (■ disk-page-number -1) 

return "Some load map specifies non-existent disk page." 

do (setf (starting-vma (aref sima i)) starting-vma) 
(sctf (number-of-uords (aref slma i)) number-of-words) 
(setf (file-page-number (aref «lma iJ> f i ie-page-number) 
(setf (disk-page-number (aref ttma i)) disk-page-number) 

finally (return NULL-string) ) ) 

(defun (load-from-map string) ((fs file-stream) 

(load-map ioad-map-array) 
(n-entries long) 
(use-microcode boote) 

(suggested-error-message-if-error string)) 
(loop uith (error-message string) 

for (i long) upfrom below n-entries 
if (not (null (setq error-message 

(do-one- load-set fs 

(starting-vma (aref •load-map i)) 
(number-of-words (aref •load-map i)) 
( f i I e-page-number {are f • J oad-map i ) ) 
usft-m i crocodc 

8uggested-error-message-i f-error) ) ) ) 
return error-message 
finally (return NULL-string) 
)) 

(defun (do-one-load-set string) ((fs file-stream) 

( s t ar t i ng-vma 1 ong) 
(number-of-uords long) 
(fi t e-page-number long) 
(use-microcode boole) 

(suggested-error-message-i f-error string)) 
(if use-microcode 

(loop uith (number-of-pages long) ■ (Ishr number-of-uords 8) 
while (> number-of-pages 8) 

as (die dpn-and-count) • (dic-for-block fs file-page-number) 
as (how-many-this-t ime long) ■ (min number-of-pages (count die)) 
as (error-message string) • (microcode-read-di sk-to-vma 

(disk-unit fs) (dpn die) 
hou-many-this-t ime starting-vma) 
if (not (null error-message)) return error-message 
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do (incf starting-vma (IshI how-many-thi s-t ime 8)) 

(decf num&cr-of-pages hou-many- this- time) 
(incf f i le-page-number hou-many-this-t ine) 
finally (return NULL-str ing) ) 
(loop uith (old-fMepos long) » (resd-f i lepos fs dm-2Gbit) 

initially (set-f i lepos-and-mode fs f i le-page-number dm-block) 

as (vma long) upfrotn start ing-vma by 2ES. below (+ starting-vna number-of-uords) 

as (dp disk-page) • (get-next-page fs) 

as (dd disk-data) - (disk-data dp) 

if (not (nul I (error-message fs))) 

return (progl (error-message fs) (setf (error-message fs) NULL-str ing) ) 

i f (or (nul I dp) 

(nul I (disk-data dp))) 
return "Unexpected error in file during load." 
do (ur i te-lbus-from-disk-data vna (aisk-data dp)) 
finally (set-f i lepos-and-mode fs old-filepos dm-3Bbit) 
(return NULL-str ing) ) ) ) 

(def type wlfdd-4-byte3 (structure 

(« (union (the-array (array byte 4)) 
(the-slong slong))))) 
(defun uri te-lbus-from-disk-data ( (starting-pma long) (dd disk-data) ) 
( I et-g t oba 1 I y ( ( I bus-map-s lot I bus-map-s I ot-for-s I ow-d i sk- ( oad i ngj ) 
initially isetf (address (aref Ibus-map Ibus-map-slot)) 

( 1 bus-address-page start ing-pma) ) 
with (4b wlfdd-4-bytes) 

for (Imach-offset long) upfrom 8 below 256. 
for (byte-offset word) upfrom C by 4 
do (setf (aref (the-array 4b) 0) 

(aref (disk-data-bytes dd) {+ byte-offset 8))) 
(setf (aref (the-array 4b) 1) 

(aref (disk-data-bytes dd) (+ byte-offset 1))) 
(setf (aref (the-array 4b) 2) 

(aref (disk-data-bytes dd) (+ byte-offset 2))) 
(setf (aref (the-array 4b) 3) 

(aref (disk-data-bytes dd) (+ byte-offset 3))) 
as (a-slong slong) - (the-slong 4b) 

as (a-byte byte) - iaref (disk-data-bytes dd) (+ byte-offset 4)) 
if (bit-test imach-offset 1) 

do (setq a-slong (->slong (rotr (logior (logand (<.8long a-slong) -1_4) 

(logand a-byte ;?ol7)) 
4)n 



(let-gtoba 

(loop 



4))) 
(setq a-byte (rotr a-byte 4)) 



do 



(incf byte-offset) jfix byte crossing 

(setq (ecc+high (aref Ibus-map lbus-«ap-9(ot) ) (logand a-byte tfol7) ) 
(setq (aref laref Ibus-data Ibus-map-slot) Imach-offset) a-slon g)))) 
«8waD-iiaD-size» 1) 



(defatowmacro «8wap-»ap-»ize» 1) 



(defun (read-board- Id long) {(number word)) 
(select number 

((8 1) (dpb Xconf ig-nemory-board XXconf ig-board-type 
(dpb -1 XXconfig- last-page 

(dpb 8 XSconf ig-f ipst-page 8)))) 
(8 (dpb tconf ig-io-board XXconf ig-board-type 8)) 
(otherwise (dpb Xconf ig-no-board XXconf ig-board-type 8)))) 

;;; vriEII access here n^s^r go through the spy bus 
(defun (setup- load-maps string) ((maps-after-initial boole) 

(ioad-map load-map-array) 
(n-load long) 
(insta-boot boole)) 
(let* ((next-map-addrestt (dpb-ior -1 XXvma-equals-pma 

(if maps-after-initial 

(wi th-spy-bus-grabbed 

(read-amem- 1 ong Xu i red-phys i ca I -address-h i gh) ) 
(loop for (n word) upfrom 8 below 16. 

while (- (Idb XXconf ig-board-type (read-board-id n)) 

Xconf i g-memory-board) 
finally (return (- (ash (long n) 19.) 

I bus-page-size)))}}) 
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(para I lei -address next-«ap-addrcs8)) 
(let ((n-load-entries (if inata-boot n-load0))) 

(setq parallel-address (+ next-«ap-address n-load-entr ies)) 

-(wri te-vmeii-!ong load-wap-stze n- load-entries) 

(wri te-vfflem-long load-»ap-address next-«ap-addre9s) ;for count-vpn 

(wr i te-v«erB-long load-map-dpn-address paral lei -address) :for disk-page-numbcr 

(loop for (i long) upfroB belou n-load-entr ies 

as (s tar t i ng-vna I ong) » (star t i ng-vna (aref • t cad-nap i ) ) 
as (number*of -words long) > (number-of -words (aref • load-nap i)) 
as (disk-page-number long) » (disk-page-number (aref •load-map i)) 
as (count-vpn long) ■ (dpb-tor ( I thr number-of-words 8) ^o2414 

(!shr start ing-vma 8)) 
do (wr i te-vmem-long next-map-address count-vpn) 

(ur i te-vmem-long parallel-address disk-page-number) 
(incf next-map-addrcss) 
(incf parallel-address)) 
(setq next-map-address parallel-address)) 

(setq parallel-address U next-map-address «suap-map-8ize«)) 
(wri te-vraem-long suap-map-size »swap-map-9ize*) 
(write-vmem-long swap-map-address next-map-address) 
(wr tte-vmem-long swap-map-dpn-address parallel-address) 
(progn 

(wri te-vmem-long next-map-addrcss S00O8.) 

(ur t te-vmem- I ong parallel-address 64000.) 

(incf next-map-address) 

(incf paral le I -address) ) 
(setq next-map-address paral let -address) 

(wri te-vmem-long bad-memory-pages-stze 0) 

(wri te-vmem- long bad-mcmory-pages-address next-map-addrcss) 

) 

NULL-string) 

(defun load-world-epilogue 
(wi th-spy-bus-grabbed 

(setq quote-NIL (read-amem tquote-nil)) 
(setq quote-T (read-amem Xquote-t)) 
) >. 

F:>LMach>Fcp>v1rtua1 -memory. in .2 



;;;-»- flode; Li I; Package: Li U Base: 8.; Lowercase: Nil -»- 

(DEFVAR «nAPPING-ENABLED« BOOLE) 

(OEF I NE -S YSDFl .ATOnnACROS 

(A-nEnORY-VARIABLES 1ST AC< -BUFFER-LOU XSTAC<-BUFFER-LiniT) 
(HI CROCODE -CONSTANTS (NIL XQUOTE-NIL) ) ) 

(DEFINE-SYSCONSTANT (A-nEnORY-VlRTUAL-AODRESS lA-rEHORY- VIRTUAL-ADDRESS) 
(PAGE-SIZE tPAGE-SI2E)) 

;;; Virtual memory versions. For now these are the same as the LBUS versions 
;;; except for the temporary memory control 
(DEFUN (READ-VriEn LBUS-UORD) ((ADDRLONG)) 
(SELECT (riAP-VIRTUAL-ADDRESS AODR) 

(1 (READ-LBUS ADOR) ) 

(2 (READ-ATIEn ADOR)) 

:(3 (REAO-PAGED-OUT-VIRTUAL-LOCATION ADOR)) 

)) 

(DEFUN URITE-VriEn ((ADOR LONG) (VAL LBLS-UORD) ) 
. (SELECT (nAP-VIRTUAL-ADDRESS ADDR) 

(1 (URITE-LBUS ADOR VAL)) 

(2 (URITE-AflEn ADDR VAL)) 

;(3 (URITE-PAGED-OUT-VIRTUAL-LOCATION ADDR VAL)) 

)) 



4,887,235 
1083 1084 

This routine takes a pointer to an address iRodifies the address 
depending on uhere the address really napped to. The return value 
tells uhere the virtual location actually lives 

Locations are: 1 -* Physical memory, 2 -► A memory, 3 -» Paged out, Addr is In fcp ■emoru. 
(DEFUN (HAP-VIRTUAL-ADDRESS WORD) ((ADDR LONG MODE REF)) 
(CCNID ((> ADDR A-nEHORY-VIRTUAL-ADDRESS) 
(SETQ ADDR (LDGAf^ 7777 ADDR)) 
2) 

;j See if it is mapped somewhere into A memory 
{(HAPPED- I NTO-A-HEnORY ADDR) 2) 
:; Check the physical address case 
((- (LDB #o3e04 ADDR) 17) 1) 

;; See if it is in the uired area. If so, relocate the address to physical start. 
(t< ADDR (READ-ADDR-FROn-AriEn tUIRED-VIRTUAL-ADORESS-HlGH) ) 
(INCF ADDR (READ-AGDR-FBOn-AflSn UirRED-PHYS I CAL- ADDRESS -LOU ) ) 
1) 

((NOT *nAPPrNG-ENABLED«} 1) 
; ; For now,. . 
(T 1))) 

;:; Like map-virtual-address, this takes an address and modifies it if it maps 
;:; into amem. Returns True if it clobbered the address 
(DEFUN (nAPPED-INTD-A-nEnORY BOOLE) ( (AODR LONG flODE REF)} 
(FROG {((BUFFER-LOU LONG))) 

(UHEN (> ADDR (READ- AODR-FROH- APEH XA-MEnORY- VIRTUAL- ADDRESS)) 
(SETQ ADDR (LOGAND 7777 ADDR)) 
(RETURN TRUE)) 
(SETQ BUFFER-LOU (READ-ADDR-FROn-AnEH XSTACK-BUFFER-LOU) ) 
(UHEN (AND im BUFFER-LOU (READ-ADDR-FRDH-AnEn XQUOTE-NID) 
(i ADDR BUFFER-LOU) 

(< ADDR (READ-ADDR-FROn-ArtEn tSTACJC-BUFFER-LiniT) )) 
(SETQ ADDR (LOGAND ADDR 1777)) 
(RETURN TRUE)) 
FALSE) ) 

(DEFUN nAPPED-ADDRESS (ADR) 

(LET* ({VPN (// ADR SYH: PAGE-SI 2E) ) 

(PPN (GETHASH-EQUAL VPN «nAPPED-ADDRESS-HASH-TABLE«) ) ) 
(IF (NULL PPN) 

(LET* ((PHT-TOP (GET-PAGING-ARRAY-TOP •SYn:«PHT*)) 
(PHT-INDEX (REnOTE-PHT-LOD<UP VPN PHT-TOP))) 
(SETQ PPN (LCDLO:REnOTE-LOAD-BYTE-DFFSET PHT-TOP 0017 PHT-INDEX)) 
(PUTHA5H-EQUAL VPN PPN *nAPPED-ADDRE5S-HASH-TABLE«) ) ) 

<+ (\ A DR SYn:P AGE-SIZE) (» PPN SYH: PAGE-SI 2E) ))) ) 

(defuiredfun pht-lookup (vpn) 

(loop with vpn-tag - (Idb XSpht-vpn-tag vpn) 
and foundp -nil 

for hash-vpn - vpn then (if U trehash-max probes) 

(rehash-vpn hash-vpn) 
(incf *count-pht-( i near-probes*) 
(1+ hash-vpn)) 
for pht-index - (\ hash-vpn «pht-st2e*) 
count t into probes 
until (or (null (pht-entry pht-index) ) 

(and (« vpn-tag (pht-vat id-vpn-tag pht-index)} 

(- vpn (let ((mmpt-index (mmpt- lookup (pht-ppn pht-index)))) 
(if (zerop (pht-pending pht-index)) 
(mmpt-vpn mrapt- index) 
(pending-get umpt-index) ) }) 
(setq foundp t)) 
(zerop (pht-coll ision-count pht-index)) 

(> probes (+ «pht-si2e* Xrehash-max 188))) • The 183 is for grins- 
finally (mcf (aref *pht-probes* (min* (1- probes) Xpht-probes-max) ) ) 
(and foundp (return pht-index)))} 



'rnieP.'.''!^,-^ S^!?^*"" *° ^" ^"^"^^^^ *^ ' ^ returns a pointer to the first data word. 
(DEFUN (GET-PAGING-ARRAY-TOP LONG) t (P-ARRAY LONG) J 

(SELECT (REnOTE-LOAD-FIELD ARRAV-DISPATCH-FIELD P-ARRAY) 
(XARRAY-DISPATCH-LEADER 
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U P-ARRAY (REHOTE-LOAD-FIELD ARRAY-LEADER-LENGTH P-ARRAY) D) 
( tXARRA Y-D I SPATCH-LONG XARRA Y-D I SPATCH-L0^4G-mLT I D I MENS I ONAL 

XARRAY-DISPATCH-SHORT-INDIRECT) 

(REnOTE-LOAO-FIELD ARRAY-INDIRECT-POINTER P-ARRAY) ) 
(OTHERUISE (1+ P-ARRAY)))) 

(DEFSUBST PHT-REHASK-VPN (VPN) (DPB VPN 32C5 (LDB 0532 VPN))) 

(DEFUN REROTE-PHT-LOOICUP (VPN PHT-TOP) 

(LOOP UITH PHT-SI2E • (LCOLD:XLDB SYn:XtQ-FIXNUP1 

(LCOLO:REnOTE-CONTENTS 

(GET *SYn:*FHT.SI2E« 'LCOLDinAGlC-VARIABLE-LOCATiaN) ) ) 
AND mPT-TOP - (GET-PAGING-ARRAY-TOP 'SYn:«nnPT*) 
AND nnPT-Y-TOP m (GET-PAGING-ARRAY-TOP 'SYTIt^cnnPT-Y*) 
UITH VPN-TAG - (LCOLD:XLDB SYn:tXPHT-VPN-TAG VPN) 
AND FOUNDP - NIL 

FOR HASH-VPN • VPN THEN (IF (£ SYn:SREHASH-nAX PROBES) 

(PHT-REHASH-VPN HASH-VPN) 
(1+ HASH- VPN)) 
FOR PHT-INDEX • (\ HASH-VPN PHT-SIZE) 
COUNT T INTO PROBES 

AS PHT-OATA - lLCDLD:R£nOTE-CONTENTS-OFFSET PHT-TOP PHT-INDEX) 
UNTIL (OR (- (LCDLDrXLDB SYn:XXQ-DATA-TYPE PHT-DATA) SYn:OTP-NIL) 
(AND (. VPN- TAG (LCOLD:XLDB 2B11 PHT-DATA)) 
(- VPN (LCOLD:REnOTE-LOAD-BYTE-OFFSET 

nnPT-TOP SYn:XxnnPT-vPN 

(REnOTE-nnPT-LOOKUP (LCOLD:XLDB 8328 PHT-DATA) flflPT-Y-TOP) )) 
(SETQ FOUNDP T)) 
(ZERDP (LCOLO:XLDB 2085 PHT-DATA)) 

(> PROBES U PHT-SI2E SYnrtREHASH-HAX 182) )) ; THE 188 IS FOR GRINS. 
FINALLY (AND FOUNDP (RETURN PHT-INDEX)))) 

(DEFUN REnOTE-mPT-LOOKUP (PPN nriPT-Y-TOP) 
(LET* {(Y (LDB SYn:tXPPN-nnPT.Y PPN))) 
(+ (LDB SYntXXPPN-nnPT-X PPN) 

(« (LCOLD: REP10TE-L0AD-BYTE-0FFSET 

nnPT-Y-TOP 

.(NTH (\ Y 4) '(8884 1884 2884 3884)) 
(// Y 4)) 

SYn:XnnPT-X-SI2E)))) 

SCRC:<LFEP-X>FPCREQ.PAL;5 

{*«- nodftiLISP; Packag«:U5ER; BatotlB -*- 



(defpal 
(IPIN 


FPCREQ PALIBLS 


11 PIO-RQ L) 


CIPIN 


9 CART-RQ L) 


(IPIN 


a lORC L) 


(IPIN 


7 Al H) 


(IPIN 


2 URITE-T58 L) 


(IPIN 


3 CART-DACK H) 


(IPIN 


4 PIO-DAC< H) 


(IPIN 


5 lOU H) 


(IPIN 


6 lOR H) 


(OPIN 12 PIO-UR-LB L) 


(OP IN 


13 PIO-UR-HS L) 


(OPIN 


19 PIO-RD-LB L) 


(OPIN 


18 PI0-RD-H3 L) 


(OPIN 


18 CART-UR-LB L) 


(OPIN 


15 CART-UR.CTL L) 


(OPIN 


17 CART-RD-LB L) 


(OPIN 


14 CART-RO-CTL L) 



(SETQ PIO-UR-LB (OR (AND PIO-RQ URITE-T50 (NOT AD) 

,^ ^ (AND PIO-DACIC lOU))) 

(SETQ PIO-UR-HB (AND PIO-RQ URITE-T58 (NOT Al))) 
(SETQ PIO-RD-LB (OR (Am PIO-RQ lORC (NOT AD) 
.^^« ^.^ ^ <AND PIO-DACK lOR))) 

(SETQ PIO-RD-HB (AfO PIO-RQ lORC (NOT Al))) 

(SETQ CART-UR-LB (OR (AND CART-RQ (NOT Al) URITE-T58) 
,^^« « ^, *WJO CART-DACK lOU))) 

(SETQ CART-tiR-CTL (AND CART-RQ Al URITE-T58)) 
(SETQ CART-RO-LB (OR (AND CART-RO (NDT Al) lORC) 

(Af4D CART-DACK lOriD) 
(SETQ CART-RD-CTL (AND CART-RQ Al lOfiC))) 
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SCRC:<LF£P-X>NAK0FEP.UC0DE:6 

t-«- rioderLISP; Package: 5 YSTEtt- INTERNALS; BasatS.; Lowercase: T -»- 
;;: Some prototype UanoFEP code 

;;; Running at about 4Bhz, the tiaar counts onco every 12Bus. 

;;; Meoory is organized as follous; 

;:; Pages 1 and 2 contain the font — each ch^^acte^ is 5 bytes lorn, Pgae 
;;; one contains characters 48 throunh 117 and page two contains 123 through 
:;: 177, Each character starts at {b»{char-40-t6£*(pagenun-l)))), 

(setq rcg-base ^Registers base address 

id-base 100 j/d prom base address 

ciock-base 3^0 :Clock/ca/endar base address 

;;; Clock/calendar locations 

(•etq clock-seconds (+ clock-base 0) 

ciock-seconds-atara {+ clock-base 1) 

ciock-Btnutes (-♦- clcck-base 2) 

c I ock-»inute5-3i arm (+ clock-base 3) 

clock-hours (+ clock-base 4) 

clock-hours-aiarm (^ ctock-baae 5) 

clock-day-of-ueek (+ clock-base 6) 

ciock-d3y-of -month (+ clock-base 7) 

clock-month <+ clock-base 10) 

clock-year (+ clock-base 11) 

clock-register-a (+ clcck-base 12) 

clcck-register-b (+ clock-base 13) 

clock-register-c {+ clock-base 14) 

clock-register-d {+ clock-base IB) 

clock-ran-base (+ clock-base 16) 

;;; Registers 

(setq disp-data-wr-reg (+ reg-base 8) 

disp-col-ur-reg (+ reg-base 1) 

freq-ctl-wr-rcg U reg-base 2} 

fep-data-wr-reg U rcg-base 3) 

power-ct i-«r-reg (+ reg-base 4) 

fep-ctl-wr-reg T+ reg-base 5) 




;;: 5u itches 

•;; msut Check the names on these 

(setq switch-any-key 27 

»witch-key-0 I switch-key-off 1 
«witch-key-l 2 swi tch-kcy-securo 2 
ewltch-key-2 4 switch-key-remote 4 
«uitch-key-3 10 ewi tch-key-local 10 
s«)tch-key-4 20 sui tch-key-remote-secure 28 
•«i tch-no 40 
switch-yes 108 
•witch-enter 200) 

;;; Fep status 
(satq fcp-e«t-bg-l 1 

fep-soH!e-rq 2 

fep- 1 bus-refresh 4 

fep-nfep-rq 10 

pouered-on 20 

fep-p lugged- in 100 

fep-soBe-rq 200) 

;;; Frequency counter control 
(setq frcq-se I -source 37 

freq-di sable-count 40 

freq-not-ctear 100 

freq-hand-clock 280 



freq-se 

freq-se 
freq-se 
freq-se 
freq-se 
freq-se 
freq-se 
freq-se 
freq-se 
freq-se 
freq-se 



-hand-clock 28 
-fep-some-rq 21 
-I bus-refresh 22 
-p5 10 
-n5.2 11 
-n2 12 
-nl2 13 
-pl2 14 
-nfep-p5 15 
-terap-e IG 
-temp-1 17) 



1089 



4,887,235 



1090 



(putprop 'nanofcp ' ( 

(- 3) 

(jmp start) 

(- 3) 

interrupt 



• tart 



»tart-l 



{- 2BB) 

(aov rd i/tf fep-statua-rd-r«g)) 

(novx a mr2) 

;; If this is the first tine, eay to and uait for a uhila 

( jb-under-easK pouered-on power-on-start) 

:; Not powered on, muet have Peen reset by user 

imoy r2 i/U reset-by-user-»ess2go) ) 

(cat 1 nfep-nessage) 

(mov a {/n 4C)) jUair about a second 
(call watt) ; based on the internal timer 

;; *** Setup clock and interrupts and stuff here 
(call update-clock) ;Update internal tine froa 



MC - PAL 



SCRC:<LMIFU>SPY.PAL;1 



X -«- nodasLitp; PackagatUser; Basa:10 -»- 

; This PAL decodes tpg addresses (saves 2 DIPs) 



(DEFPAL 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 



SPY PAL1BL8 
3 SPY-ADDR.5) 
SPY-AOOR-4) 
SPY.ADDR-3) 
SPY-ADDR-2) 
SPY-ADDR-l) 
SPY-ADDR-0) 
SPY-WRITE L) 
SPY-READ L) 



(FIELD SPV-ADDR SPY-ADOR-S SPY-ADDR-4 SPY-ADDR-3 SPY-AODR-2 SPY-ADDR-l SPY-ADDR-8) 

(OPIN 18 SPY-URITE-41 L) 

(OPIN 17 SPY-URITE-Ae L) 

(OPIN 16 SPY.READ-45 L) 

(OPIN 15 SPY-READ-44 L) 

(OPIN 14 SPY-READ-43 L) 

(OPIN 13 SPY-READ-42 L) 

(OPIN 19 SPY-READ-41 L) 

(OPIN 12 SPY.READ-40 L) 



(SETQ SPY-READ-40 
(SETQ SPY-READ-41 
(SETQ SPY-READ-42 
(SETQ SPY-READ-43 
(SETQ SPY-READ-44 
(SETQ SPY-READ-45 



(AND SPY-WEAD 
(AND SPY-READ 
(AND SPY-READ 
(AND SPY-READ 
(AND SPY -READ 
(AND SPY-READ 



(FIELD SPY. 
(FIELD SPY- 
(FIELD SPY- 
AFIELD SPY- 
(FIELD SPY- 
(FIELD SPY- 



•ADDR 
-ADDR 
•ADDR 
•ADDR 
•ADDR 
ADDR 



«ro40) ) ) 
#o41))) 

J(ro42) ) ) 
UoUZ))) 
#044))) 
*o45) ) ) 



{§119 S^-HSIIi-^® ^^^ SPY-URITE (FIELD SPY-ADOR Uom)) 
_(SETQ SPY-URlTE-41 (AND SPY-i«ITE (FIELD SPY-ADOR «o41)))) 

-*- node: Lisp; Package: User; Base: 18 -»- 

This PAL controls Abus sources (and bidirectional transceivers) 



(DEFPAL SOURCE PAL1SL8 

;: Microinstruction inputs 
(IPIN 6 ABUS-SOURCE) 
(IPIN 7 U-AnRA-8) 
(IPIN 8 U-AnRA-7) 
(IPIN 9 U-AnRA-6) 

;t Other inputs 

(IPIN 4 EnULATOR-TASIC) 

(IPIN 5 USE-AflEn- INSTEAD) 



tUa are to drive the Abus 



;ABem substitutes for HO source 



;: For bidirectional transceiver control 
(IPIN 11 AOOR-FROn-ABUS) 
(IPIN 3 nAP-SEL-0) 
(IPIN 1 riAP-B-tWITE) 
(IPIN 2 nAP-A-URITE) 
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;; Abus source select outputs 
iOPIN 18 lO-MO-TO-ABUS L) 
(OPIN 17 EnU-nO-TO-ABUS L) 
(OP IN 16 PC-TO-ABUS L) 
(OPIN 15 VriA-TO-ABUS L) 
(OPIN 14 riAP-TO-ABUS U 
(OPIN 13 ABUS-XCV-23.0-EN U 
(OPIN 13 ABUS-XCV-31-24-B-EN L) 
(OPIN 12 ABUS-XCV-31-24-A-EN L) 

;; Abus source select 

(^lELD ASOURCE U-AHRA-S U-AnRA-7 U-AtlRA-G) 

(SETQ riEn-TO-ABUS (AND ABUS-SOLfRCE (FIELD ASOURCE 0))) 

(SETQ LBUS-TO-ABUS (AND A8US-S0URCE (FIELD ASOURCE 1))) 

(SETQ VHA-TO-ABUS (AND ABUS-5QURCE (FIELD ASOURCE 2))) 

(SETQ HAP-TO-ABUS (AND ABUS-SOURCE (FIELD ASOURCE 3))) 

(SETQ PC-TO-ABUS (AND ABUS-SOURCE (FIELD ASOURCE 4})} 

;; The emulator MDs are used only for enulator-task aemorg reads. 

;; The ID PtD is used for non-emuTator-task «c«ory reads, ■icrodevice reads, 

;; and diaonostic data from the FEP. 

(§ETQ EHU-RD-TO-ABUS (AND nEH-TO-ABUS (NOT USE- AMEn- INSTEAD) EflULATOR-TASK) ) 

(SETQ lO-nO-TO-ABUS (OR LBUS-TO-ABUS 

(AND riEn-TO-ABUS imi USE-AHEM. INSTEAD) (NOT ETIULATOR-TASK) ) ) ) 



read i no aap, reading VMA, or taking 
from Abus„ (which includes wr|ting map Tjust for parity conputationD 



if 



;; Address to/from Abus enabled 

;; from Abus (which includes writing map I just for parity 

(§ETQ ABUS-XCV-23-0-EN (OR ttAP-TD-ABUS VHA-TO-ABUS ADDR-FROn-ABUS) ) 

;; Enable VHA Key bits of map that hits onto Abus when reading map; if 
;; hits then pick one "at random**. Drive VPIA Key bits of whichever ma 



address 



;; being written from the Abus, 



neither 

maps are 



(kTQ A6US-XCV-31-24.A-EN (OR 
(SETQ ABUS-XCV-31-24-B-EN (OR 

SCRC:<LMIFU>MDCTL1.PAL;1 



(AND MAP-TO-ABUS MAP-SEL-S) ttAP-A-URlTE)) 

M€i ftAP-TO-ABUS (NOT nAP-S£L-8) ) riAP-B-WRI TEH ) 



; *»- node:Li8p; Package:Usert Base: 18 -«- 
; ff}CTL: ff3 controls 



(DEFPAL rCCTLl 


PAL16R8 


;: Inputs 
({PIN 2 BL<-! 


3F) 


(IPIN 3 ADDR- 


.FROn-VMA) 


(IPIN 4 ADDR- 


-0-A) 


(IPIN 5 LBUS- 


-REQUEST-B L) 


(IPIN 6 SPY-I 


.OAD-nO) 


(IPIN 7 PROC- 


"READ-ACTIVE L) 


(IPIN 8 EHULATOR-TASK) 


(IPIN 9 LBUS-UAIT L) 



;: Registered outputs 
(ftPlN 18 lO-nO-FRdn-LBUS L) 
(RPIN 17 Em-nD0-FROn-LBUS L) 
(RPIN 16 EnU-nOl-FROn-LBUS L) 
(RPIN 15 ADDR-FROn-VnA-A) 
(RPIN 14 EnULATOR-TASK-A) 
(RPIN 13 BLK-PF-D) 
(RPIN 12 BLK-PF-A) 



{Page fault when starting block read 

jAddress coming from VriA 

sLow-order address bit in data stage 

;Anu Lbus cucie starting 

;FEP wants nO to capture write data 

t Active cycle of processor read 

;nicroinstruction is for emulator 

jLbus pipeline doesn't advance this cycle 

{Latch Lbus data in 10 KD 
;Latch Lbus data in even emulator MD 
{Latch Lbus data in odd emulator MD 
{Active cycle, address came from VHA 
{Active cycle, was started by emulator 
{Block-read page fault (data cycle) 
{Block-read page fault (active cycle) 



;; Rain PC loading controls 

:; If not a virtual memory read, load both emulator ttO's sines we 

;; don t know for sure which one wit) be gated onto the Abus. 

(SETQ NEXT-EnU-mi-FROn-LBUS (AND TxTl^Sc^S^AfE^Y^ If^g^AfoS^-fAi^^-A^-*' ' » ^ 

.«-m ..-wT Tn ^ P,^«- ^^ ADDR-0-A (NOT ADDR-FROn-VflA-A) ) ) ) 

(SETQ NEXT-IO-nD-FROn-LBUS (OR (AND NEXT-PROC-DATA-CYC (NOT EHULATDR-TASK-A) ) 

(AND LBUS-REQUEST-B SPY-LOAO-riD))) 

;s True during the first clock of a data cycle for the orocessor 
(§ETQ fCXT-PROC-DATA-CYC (AND PROC-READ-ACTIVE (NOT JuS-UAIT?°) 

{: Bus state pipel ine 
(SETQ NEXT-ADDR-FROn-VriA-A (OR (AND 

(AND 

(SETQ >CXT.EnULATOR-TAS<-A (OR (AND 

_ (AND 

(SETQ f€XT-BLK-PF.D (OR (AND BLK-PF^ 

(AND BLIC-PF- 
(SETQ NEXT-BLJC-PF-A (OR (AND BLK-PF 

(AND BLK-PF- 



ADDR-FROn-VnA (NOT LBUS-UAIT)) 
ADDR-FROn-VnA-A LBUS-UAIT))) 
EnULATOR-TASK (NOT LBUS-UAIT) ) 
EflULATOR-TASIC.A LBUS-UAI T) ) ) 
•A (NOT LBUS-UAIT)) 
■D LBUS-UAIT))} 
(NOT LBUS-UAIT)) 
■A LBUS-UAIT)))) 
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(UthHAL nOCTLl PAL16R8 


; Inputs 

{ PIN 2 BLIC-PF) 


{ PIN 3 ADDR-FROn-VriA) 


CIPIN 4 ADOR-0-A) 


(IPIN S LBUS-REQUEST-B L) 


(IPIN 6 SPY-LOAD-rtD) 


(IPIN 7 PRX-READ-ACTIVE L) 


(IPIN 8 EnULATOR-TASK) 


(IPIN 3 LBUS-UAIT L) 



;: Registered outputs 
(ftPIN 18 lO-nO-FROn-LBUS L) 

(RPIN 17 Enu-nDe-FRort-Laiis d 

(RPIN IB EPIU-nDl-FROn-4-BUS L) 
(RPIN 15 ADOR-FROn-VnA-A) 
{RPIN 14 EnULATOR-TAS<-A) 
(RPIN 13 BLK-PF-0> 
(RPIN 12 BU-PF-A) 



tPage fault uhen starting block read 

J Address coming from VPIA 

;Lou-order address bit in data stage 

{Any Lbus cucle starting 

:F£p uants nO to capture urite data 

(Acttvs cycle of processor read 

jHicroinstruct ion is for emulator 

;Lbus pipeline doesn't advance this cycle 



tLatch Lbus data in 10 MO 
iLatch Lbus data in even emulator ftO 
:Latch Lbus data in odd emulator DO 
; Active cycle, address came from VriA 
;Active cycle, was started by emulator 
tglock-read page fault (data cycle) 
sB lock-read page fault (active cycle) 



;; fUin HO loading controls 

t: If not a virtual aenoru read, toad both eaulator flO's since ue 

t; don't knoM for sure which one ui I t be gated onto the Abus. 

lkVS'fei?.E"aj:irii^JSSn!CI5l*lA^'Nk5»!S?lA":^rEH5ii/ltoR.TAs<.A 

(SETQ rcxT-Em-mi^i-LBus (ATD ^xtTrJc^oS?a?E*v1: ^SS^Afo^^i^Ai^^A^-*'"' 

,«-^ .--w* ,« ^ r.,.^- . ^^ ADDR-8-A (NOT AODR-FROn-VnA-A) } ) ) 

(SETQ NEXT-IO-rO-FROn-LBUS (OR (AND NEXT-PRCC-DATA-CYC (NOT EnULATOR-TASK-A)) 

(AND LBUS-REQUEST-B SPY4.0AD-nD) ) ) 

5i^l!l^-^"'"'"a '^^^ first clock of a data cycle for the processor 
(SETQ NEXT-PROC-DATA-CYC (AND PROC-READ-ACTlVE (NOT LBUS-UAIT))) 

s: Bus state pipeline 

(SETQ NEXT-ADDR-FROn-VnA-A (OR (AND ADDR-FROn-VTIA (NOT LBUS-UAIT)) 
*«-^ .iP-w^ ^. .*^ ^ ^ ^ <*ND ADOR-FROn-VflA-A LBUS-UAIT))) 
(SETQ NEXT-ETULATOR-TASJC-A (OR (AND EttULATOR-TASK (NOT LBUS-UAIT)) 
_^ (AND EHULATOR-TASK-A LBUS-UAIT))) 

(SETQ NEXT-BU-PF-O (OR (AND BLK-PF-A (NOT LBUS-UAIT)) 

(AND BL<-PF-0 LBUS-UAIT))) 
(SETQ NEXT-BLIC-PF-A (OR (AND BLIf-PF (NOT LBUS-UAIT)) 

(AND BLK-PF-A LBUS-UAIT)))) 

SCRC : <LMI FU>MDCTL . PAL ; 1 



t -*- node:Liep; Package;User; Base:lB -»- 
; nbCTL: VHA-OFFSET PAL 



(DEFPAL nXTL PAL16R4 


;: Inputs 


(iPIN 2 u-riEn-i) 


(IPIN 3 U-PIEn-0) 


(IPIN 4 nc-nAP-niss d 


(IPIN 5 EnULATOR-TASK) 


(IPIN S NOP) 


(IPIN 7 u-rEn.2) 


(IPIN 8 LBUS.IN-0) 


(IPIN 9 LOAD-PC L) 



jTske map miss trap 

jEmulator running now 

Ipon't execute microinstruction 

; Increment VttA 

; Input to low-order bit of VMA 

Uaplies vriA being loaded 

;Low bit of VRA that goes with emu fID 
$How far VMA is ahead of emu flD 



;Supprees loading MO with result of this read 

ll ran out of inverters 

J Load VHA from Lbus 

I Have to make two passes through PAL 



t: Regieter bi te 
(RPIN 16 VnA-FOR-ttD-0) 
(RPIN 15 Vru-OFFSET-I) 
(RPIN 14 VnA-OFFSET-0) 

It Unregistered outputs 
(OPIN 19 DONT-START-REAO) 
(OPIN 18 VMA-FOR-rO-B L) 
(OPIN 13 LOAD-VnA-OUT L) 
(IPIN 13 LOAD-VriA L) 

(FIELD f€n u-nEn-2 u-fEtt-i u-nEn-0) 

U^JfD^ ie^ loaded by nETI function 5, and when PC is 

(SETQ LOAD- VttA-OUT'' (Arc (OR (FIELD OEfl 5) LOAD-PC) (NOT NOP))) 

:: !2^°!^"* *=*"■"? ^^^^.^ *? loaded, increases when YHA is incremented, 

M decreases as emulator task microinstructions get executed, VttA offset 

;s IS mean.noful m the data-cycle part of the pTpeline, hence in the active 

;; cucle part of the pipeline rt will always be 2. ■cxive 

Ur?n r2.V?Tno'2.5^'^?.^9",-2.Hri59«*,*3**^<^*^ "** ^ *« (ought to be zero). 
iSilS ?ry-ATOR-RlW (AND EnULATOR-TASK (NOT NOP))) 
(SETQ NC-VttA (AND EnULATOR-RUN U-nEn-2)) 



error 

088 

and ue 
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(SETQ N£XT-VnA-OFFSET-l 

(OR iNC-VnA :Set uhen VMA tncrenentpH 

<AND (NOT EnULATOR-flUN) vnA-OFFSET-l)j"f '""^'fHold 

sSot to zero when Hulator run Mithout 
(SETQ NEXT.vnA-OFFSET-0 ' .ncre.enting VttA 

(NOT INC-VflA) :C ear when VriA increment^rf ftn 7\ 

(OR (AND EnULATOR-RUN VHA-OfFSET-lV CoCnt doSn 
(AND (NOT EnULATOR.RUN) VnA-OFFSET-0)))r,Hold 

;: yrw FDR no 18 VriA a xor'ed utth VTlA-OFFSET-e 

UeTQ NEXTf^l^tFCRfnoJ'''' *'• ''*' '^^^^^ ^*="' "°^ '" -^^'^^ ^«^'"> 
(COND (LOAD-VnA LBlfS-IN-e) : Loads from eame thino as VTIA 

(AND EnULATOR.RUN (NOT LQAO-VnA) (NOT INC-VHA} ' *"^'^*'»*^*» ' ^**'» ^^ 

(XOR VflA-FOR-nO-e NEXT-VftA-OFFSET-B)) ;1 uord/2 cucIm ease 
((NOT EnULATOR-RUN) VrtA^OR-rtO-S)}) JHoiS ^ 

;; Any time a read ^ets started but then NOP comes on, ue uoutd tike to 

;: •uPPress ciobberTng of flD.with the result. For example" if ther2 i2 

:; a breakpoint set on the aicrotnstruction, the machine will be 

;; committed to doing the read before the microinstruction paritu 

:: Sf2^^!**®!^^^"^l *^"^*=*^*,H5**?*y• «• can't just make NOP supprS 

;; read-starting, because NOP migfit be on because of a map miSs. „.« 

;: don twant to suppress loading of the PHT entry into fio, Th s is 

;; especially important in a block read, where HO is really being used 

;; by the microinstruction that starts a read. w " 'w «"» 

!: ^L^TMr^ncc'^rC ^''^^'^^^^ reading into ttO except when a map miss occurs. 

i: tn! I^-°£SICN for a discussion of the restrictions this imposes on 

(§ElQ*ooNf:i?^^?:R^5^^S^R6r(S§!^^^^ "*^^ °^^- *^»p- 

SCRC:<LHIFU>MAP,PAL:1 

; -«- f1ode:Lisp; Package: User; Base: 10 -»- 

; Map and trap controls 

CDEFPAL ttAP PAL1BL8 
;: Inputs 

(IPIN 14 VTIA-OFFSET-l) 

UPIN 13 VnA.OFFSET-0) 

(IPIN 1 rC-PF) 

UPIN 2 EnU-nO-TO-ABUS L) 

}jP}N 3 SPEC-CHECK-URITE-ACCESS L) 

(IPIN 4 URITE-PERHIT L) 

(IPIN 5 HAP-SEL-l) 

(IPIN 6 nAP.S£L-0) 

(IPIN 7 ADDR-FROn-flAP) 

(IPIN 8 PROC-GRANT) 

(IPIN 3 SPEC-USE-PHTA L) 

(IPIN 11 U-nEtt-B) 

:; Outputs 

fSEIf ^§ ADOR.7-0-FROn-VnA) 

(QPIN 17 URITE-LRU) 

(OPiN 16 nc-MAP-mss L) 

(OPIN 15 BLK-PF) 

(OPIN 19 ttC-TRAP.pARAn-1) 

(OPIN 12 nC-TRAP-PARAn.0) 

(FIB-D VHA-OFFSET VHA-OFFSET-l VTIA-OFFSET-B) 
(FIELD flAP-SEL flAP-SEL-l flAP-SEL-S) 

(^TQ BLOCK-OP (NOT (FIELD VHA-OFFSET 0))) 
(^TQ BLOC<.READ (AND BLOC(C-DP (NOT U-HEn-B))) 
(SETQ BLOOC-URITE (AND BLOCX-OP U-nEri-0)) 

(SETQ MAP-HIT (NOT (FIELD flAP-SEL 0))) 

»j Ui thin-page addr bits come from VttA except uhen they come from PHTA. 

:: ^Vh'!: ? ^i^'lt ^"=^ '=*^ "^'*** "• ■"»*"'* '"'tch to'^PHTA bccause^th s 

;: cou d select the same memory bank as in the previous cycle, which 

UrVS"lA«!:;°!;*^^*P5<.=°"'^ "'Pe out the memory. ^ ^^y^m. wnicn 

(SETQ ADOR-7.B-FR0n-VnA (OR BLOOC-OP flAP-HIT) ) 

•/iL-!fc'.*^,iD®. t^ memoru whenever ue get a real mao hit 

(SETQ URITE-LRU (AND PfiOC-GRANT ADDRlFROn-riAP (FlLo HAP-SEL (12)))) 

(NOT URITE-PERHIT) 

(OR U-nEri-0 SPEC-CHECX-URI TE-ACCESS) ) ) 

'/^?S^Sr^'^E2P,i/ "^p miss in block read 
HIS Sb^^EEr-i^^ HAP-niSS BLOC<-REAO)) 
(SETQ DEFERRED-nAP-niSS (AND EnU-tlO-TD-ABUS HD-PF)) 
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;: iwie nap niss trap if non-block ■iss, urite vie 
(§ETQ nC-HAP-niSS (OR (AND flAP-MISS (NOt BLK-PF)) 

UmTE-VlQLATlOH 
D£F£RRED-nAP-niSS)) 

;; Trap parameter interpretation it as foltout: 

;; 8 - noma! page fault, PHTC read in progress 

:; 1 - block read, VHA offset - 1, no PHTC probe 

;? 2 - block read, VMA offset - 2. no PHTC probe 

;; 3 - block write, VtlA offset - 0, no PHTC probe 

;; or wri te-protect violation 

;; (Kicrocode ui I t have to read the aap to tell Mhich) 

;: It is illegal to do a urite or urtte-check in the middle of a block read, 
:: so the VMA offset for a uri te-protect violation is zero. 
(SETQ nC-TRAP-PARAn-1 (OR URITE-vTOLATION 

BLOC<.URITE 

(AND VMA-OFFSET-l (NOT U-nEH-e)))) 
(SETQ nC-TRAP-PARAtl-e (OR URITE-VIOLATION 

BLOCK -URITE 

(A ND VnA-OFFSET-g (NOT U -nEH-B) ) ) ) ) 

F :>lmach>f ep>debug .LIT. 11 

(sctq «potnt-stack-pointer» (logand (1- mpoint-stack-pointer*) 7))) 

(defun debug- indirect-through-current-value 
(if (not «point-open?«) 

(forwat t " ?Locatton? ") 
(setq *point« *t2b-point*) 
(deoug-read-point) 
(debug-pr int-current-va (ue)> I 

(defun debug-read-point 

(setq «tab-point-va! id« true) ;u8uatty 

(let (doc (value «point»))} 
(ui th-spy-bus-grabbed 

(funcali (select («etn-type scpoint*) 
(vMea tf'debug-read-veem) 
(amen ^^'dsfcug-read-amem) 
(bmem ^*debug-read-bmeffl) 
(cmem tf*debug-read-cmem} 
( type-map U' debug-r ead- type-map) 
(d I sp I ay-mem W debug-read-d i sp I ay-mem) 
(gc-map #*debug-read-gc-map) 
) 
loc)))) 

(defun dcbug-va J ue-from- 1 bus-word 

(setq »tab-potnt« (location-and-mem-type (data »debug- 1 bus-word*) vmen))) 

(defun dcbug-read-vmem I (Ice long)) 

(setq *debug-i bus-word* (read-v«em loc)) 

(debug-va I ue- from- 1 bus-word) ) 
(defun debug-read-amem ((loc long)) 

(setq sdebug- 1 bus-word* (read-amem loc)) 

(debug-va I ue- f rom- 1 bus-word) > 
(defun debug-read-bmem ((loc long)) 

(setq *debug- 1 bus-word* (read-bmem loc)) 

(debug-va f ue- f rom- 1 bus-word) ) 
(defun debug-read-di splay-mem ((loc long)) 

(setq *debug- 1 bus-word* (read-di spt ay-mem loc)) 

(debug-va I ue-f rom- 1 bus-word) ) 
(defun debug-r ead-cmem ((loc long)) 

(read-cmem (word I oc) «debug-m i cro i ns true t i on*) 

(setq *tab-point-val td* false)) 
(defun debug-read-type-map ((loc long)) 

(setq *debug-tong* (read-type-map toe)) 

(setq »tab-point-val id* false)) 
(defun debug-r ead-gc-map ((foe long)) 

(setq *debug- long* (read-gc-map loc)) 

(setq »tab-point-val id* false)) 

(defun debug-depost t-va!ue-to-point 
(setq *point* «point*)) 
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(defun dfibug-print-current-value 

(setq *point« irpoint*)) 
(defun (read-display-mem Ibus-uord) ((loc long)) 
«de£)ug- i bua-uopd*) 

F:>LMach>Fep>boot-contro1 .Lil ,4 



;s;-*- node: LiU Package: Lit; Ba3e:S.; Lowercase: T -»- 

(include "Type8-and-«acpo»"} 
(include "atpeao.EXT" "etrmg.EXT^) 

(defvariini tfun ini t-boot-parameters 
boot-status boot-status bs-succe;s 
boot-status-»essage string NULL-string 

bp-check-pouep-ok boole false 
bp-powep-ok boole false 

bp-«icpocode-8tpca« stpea* NULL-8tpea» 

bp-»icpocode-unit uopd Q 

bp-«icpocode-filenaBe string NULL-stping -uses this if stpeaa is NULL 

bp-load-tticpocode boole false 
bp-n»cpocode- loaded boole false 
bp-veptfy-aicpocode boole false 
bp-»icpocode-vepif ted boole false 

bp-tenp-wopld-fi le-stpean file-strea* fAiLL-f i le-stpeam 

bp-wopld-strea» stpeaa fA/LL-stpeam 

bp-wop Id-uni t word 8 

bp-wopld-f i lename string NULL-stping 

bp-vcptfy-wopld-f i le boole false 

bp-wopld-f i ie-vepif ied boole fa\9e 

bp-load-spapse boole false 
bp-spapse- loaded boole false 
bp-vepify-spapse boole false 
bp-spapse-vepif ied boole false 

bp-ioad-ini tial boole false 
bp-use-«(cpocode-fop-load-initial boole false 
bp-ini tial -loaded boole false 

bp-setup-maps boole false 

bp-put-iiiaps-3ftep.ini tial boole false :not until OanG does nax of mopo things 

bp-Baps-setup boole false 

bp-ppe load- load boole false 
bp-use-micpocode-fop-ppe toad- load boole false 
bp- I oad-ppe loaded boole false 

bp-setup-phtc boole false 
bp-phtc-setup boole false 
) 

(defun peset-boot-papameteps 

(unless (null bp-micpocode-stpeam) (stpeam-close bp-micpocode-stpeam) ) 

unless (null bp-micpocode-fi lename) (retupn-stping bp-micpocode-fi lename)) 

unless (null bp-uop Id-stpeam) (stpeam-close bp-uopld-stpeam)) 

(unless (null bp-uop I d-fi lename) (retupn-stping bp-uop I d-fi lename)) 

(defun peinit-boot-papameteps 
• "(reset-boot-parameteps) 
(init-boot-papameteps)) 

(defun (machine-memopics- loaded boole) 

(and bp-pouep-ok 
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bp-m i crocode- 1 oaded 

(op (not bp-vcpi fy-»icPOCOde) bp-«tcPocode-vcpi f ied) 

(op (not bp-vep]fy-uopld-f i le) bp-wopld-f i le-vcpt f ied) 

bp-Bpapse- loaded 

(op (not bp-vepi fy-spapse) bp-spapse-vept f ted) 

bp-ini t tal-ioaded 

bp-maps-aetup 

(op (not bp-ppe I oad- ! oad) bp- I oad-ppe I oaded) 

bp-phtc-sctup _ 

n " "" ' " " 



LIL SUMMARY 



LIL Summary 

This document describes LIL, a Lisp-like Implementation Language* 



The phrase "as in Lisp" appears throughout this document. In these cases, refer to the 
documentation on Zetalisp for the exact syntax or semantics of the language feature being 
disozssed. 

LIL Overview 

LIL is a language for system programming. Its main application here is in code for the front end 
processors. ♦•needs info** . The LIL compiler is written in Lisp. 

The best way to understand LIL is as a language with Lisp syntax and Pascal semantics. A LIL 
source program is a list and the LIL compiler reads the source using the Lisp reader. On the 
other hand, programs written in LIL operate only on numbers. The concepts of symbols, atoms, 
and lists are not part of LIL. 

LIL is a strongly typed language. It has user-defined types but no user-defined generic operations. 
Variable references are lexically scoped. Function and type declarations must be at top level; they 
cannot be nested. 

The design and names of various LIL language features were taken directly from Lisp. In 
particular, LIL programs can contain Lisp macros, whose expansion is handled by the compiler. 



Notation Conventions 

This section describes how to read the definitions. 

- All parentheses that appear are required as shown. Parentheses are not part of the 
meta-syntactic notation. 

- Words in uppercase are keywords in the language. LIL itself has no case 
requirements. 

- Words in lowercase are nonterminals in the definition. Keep looking until you find 
the expansion. Nonterminals like "type-identifier" follow the same rules as for 
"identifier" and do not have separate expansions in the definitions. When space is 
limited, the "id" appears as an abbreviation for "identifier" and "expr" for 
"expression". 
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• Elements in italics are optional and can simply be omitted. When one of the elements 
is underlined, it is the default one. 

' Sets of possibilties appear in braces: { }. Within the braces, mutually exclusive 
possibilities are separated by an upright bar: |. Other possibilities are separated by 
commas. Some definitions have nested sets of braces. 



LIL Concepts and Syntax 

Type declarations 

Everything in LIL must have a type. You have to declare identifJers as being of a certain type. 
Every expression has a type. For example, the type of LET is the type of its last form. All types 
have to match or be coercible. 

DEFTYPE defines an identifier as the name of a type; DEFGLOBAL declares an identifier as an 
instance of the type. The compiler permits forward references so you can use a type before 
defining it. Type declarations do not contain values for initializing objects of the type. 
(Initializing has to be done when you declare the identifier for the object.) 

Type definitions must appear at top level. Identifier declarations can appear anywhere and are 
lexically scoped. LIL has four predefined types: WORD, BYTE, LONG, and BOOLE. LIL has 
four type constructon for user-defined types. No user-defined generic operations are available. 

One class of types in LIL contains the numeric types, WORD, BYTE, LONG, and UL generic 
number, LIL generic number is an internal type that is used for numeric literals until they can be 
assigned to one of the other numeric types. Generic numbers are cotrctd to one of the basic 
numeric types as soon as the appropriate type can be determined. 

The type constructors for user-defined types can create two classes of types: aggregate (structure 
types) and nonaggregate (enumeration, pointer, and array types). 

Enumeration For associating members of a class or category. The type is formed by naming 

the literals of the type or by providing a subrange from another type. 

Example: 

(deftyp« boo1« (enumeration false true)) 
(deftype byte (enumeration (-128 127))) 
(deftype days (enumeration Sunday monday tuesday Wednesday 

thursday friday Saturday)) 

The type defim'tion also declares the literals as global identifiers. The 
identifiers caimot be redefined. 
Pointer For providing pointers to user-defined types. 

(deftype status-ptr-type (pointer status-record-type)) 

^^'■^y For arrays of any named type or arrays of implicit enumeration, pointer, or 

array types. The number of dimensions possible for any array is not limited. 
As in Lisp, all array accesses are rero-based and the number in the dimension 
spec refers to a number one larger than the index of the last clement in the 
array. The type of the array index must be numeric. 

(deftype map-type (array word 128)) 

(deftype counter-array- type (array counter- type (-128 128))) 

See also the section that collects all of the details about arrays. 
Structure For collections of objects, each of which can have any type. The objects are 

called fields. 



4,887,235 
1105 1106 

Symbolics, Inc. 



(deftype str-typ» 
(structure () 
(ntxt code*symbol) 
(kind symbol'lclnd) 
(Mln1mum-loc word) 
(naximun-loc word))) 

See also the section that collects all of the details about structures. 

Formal syntax for types 

typ)e-definition ::* (DEFTYPE type-identifier type-generator) 

type-generator ::= { noncomposite-type-gen | composite-type-gen } 

noncomposite-type-gen ::= {WORD 

BYTE 
BOOLE 
LONG 
{ (ENUMERATION literal-idl . literal-ids) \ 

(ENUMERATION (min-litcral-id max-literal-id)) } ) 
(POINTER type-id) | 
(ARRAY array-type-gen dim-spec 1 . dim-specs) 

} 

array-type-gen ::= { type-id | noncomposite-type-gen } 

dim-spec ::* { size | (first last+1) } 

composite-type-gen ::= (STRUCTURE option-list 

(field-id 1 noncomposite-type-gen) 

(field-idn noncomposite-type-gen)) 

option-list ::= ( (INCLUDE structure-type-id) , 
PRESERVE-ORDER ) 

Declarations 

The following constructs declare identifiers: 

DEFGLOBAL Declares identifiers for global static variables. 
DEFMANIFEST Declares identifiers for global compile time constants. 
DEFTYPE Declares type identifiers and literals for enumeration types. 

DEFUN Declares formal parameter identifiers for functions. 

LET Declares identifien for lexically scoped local variables. 

In LET, the identifier being declared must have a type. Either you specify the type explicitly or 
it inherits its type from the type of the expression used to define it. As in Lisp, LET specifies 
parallel binding of the identifiers; LET* specifies sequential binding. 

Formal syntax for declarations 

declaration ::« { global-declaration | let-declaration | 
parameter-declaration } 
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global-declaration ::= { ( DEFGLOBAL id-declaration . id-declaration) \ 
(DEFMANIFEST ????) } 

id-declaration ::= ( identifier type-identifier . option-list ) 

option-list ::= ( { VOLATILE , 

(ADDRESS expression) , 
(ALIG.NfMENT {WORD | LONG}) , 
(I>JIT expression) 
}) 

let-declaration ::= { ( LET binding-form-list body) | 
(LET* binding-form-list body) } 

binding-form-list ::= ( binding-form . Innding-form ) 
binding-form ::= { (identifier expression) | 

((identifier type-id) expression)] 

Operators 

LIL has a standard set of arithmetic, logical, and relational operators. 

The arithmetic operators are generic. That is, they work on any numeric operands regardless of 
their internal type. The types for numeric values arc WORD, BYTE, and LONG. Numeric 
literals are of type LDL-generic-number. (Numeric literals are decimal, not octal. Use #0 as in 
Lisp to enter literal octal values.) The compiler does coercion on operands to make the tj'pes 
match. 

The arithmetic operators: 

+ 



// 
\ 

ML\ 
MAX 

Logical operators do bit-wise logical operations on numeric type operands. They return numeric 
values._ 

The logical operators: 

LOG AND 

LOGIOR 

LOGXOR 

LOGNOT 

LSHL 

LSHR 

ASHL 

ASHR 

ROTL 

ROTR 

Relational operators take operands of ordered (enumerated) types only and return a value of tvoe 
boole. ^^ 

The relational operators: 

< 

5 
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> 

The syntax of all operators is as in Lisp. 

Assignment 

The assignment operators are SETQ and PSETQ. You can do whole array or whole structure 
assignment, so long as the types are compatible. SETQ docs assignments sequentially; PSETQ 
docs all of the assignments in parallel. As in Lisp, SETQ returns the value of the last form 
evaluated. PSETQ returns 7771. 

For assigning initial values to identifiers, sec LET and the INTT option of DEFGLOBAL. 
Formal syntax for assignment 

assignment ::= { (SETQ assignments) | 
(PSETQ assignments) } 

assignments ::= identifier expression . assignments 

Expressions 

LIL is an expression language. With the notable exception of PRCX3, each form has a value. 
Details of expressions that involve array and structure selectors appear in the sections on arrays 
and structures. 

The pointer dereferencing operator is ®. The value of ©identifier is the object that the pointer 
points to. Its type is the type of the thing pointed to. 

expression ::= { literal | 
identifier j 

function-application ] 
prog-form j 
pointer-dereference | 

(AREF array-identifier dimension-value . dimension-valve) | 
(structure-ficld-id structure-identifier) } 

Arrays 

An array is simply a collection of objects, ail of which have the same type, that are selected 
according to an element index. You can have arrays of anything, including arrays of arrays and 
arrays of structures. 

Defining an array type. 

The type of the array index must be numeric. At this time, the sizes of all array dimension specs 
must be compile-time constants. 

(deftypt aap-typt (array word IZB)) 

(deftypt countar-array-typ* iarray counter-type (-128 128))) 

Declaring an array object, 

(def global (key-nap nap- type) 
(alt-nap nap-type)) 

Array constructors. 

Array literals. 

Array element assignment. 

Array element assignment looks the same as in Lisp. 
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(SETF selector-expression expression) 

,(setf (aref counts bin) 36) 

Array element selectors. 

As in Lisp, all array accesses are zero-based and the number in tht dimension spec refers to a 
number one larger than the index of the last cicment in the array. Array elements are selected 
by AREF and the appropriate index(es). The type of the index must be numeric. LDL does not 
provide array slices so you need one index for each dimension of the array. 

(aref counters 4 27) 

(setq t (aref key-map #\neta-ffl)) 

Structures 

A structure is a heterogeneous collection of objects, called fields. Structure fields can have any 

type. 

Defining a structure type 

Structures are composed of hetergeneous objects. The compiler usually rearranges structure fields 
internally so as to make optimal use of storage space for an object of that type. 

Sometimes you need to ensure that the fields remain in the order in which you declared them (for 
example, setting up packets for network transmission). PRESERVE-ORDER is an option on a 
structure type definition for requesting that fields in the object remain in the same order as fields 
in the definition. 

(deftype str-type 
(structure () 
(next code-symbol) 
(kind symbol-kind) 
(nlnlnum-loc word) 
(naxlmum-loc word))) 

Declaring a structure object 

Structure constructors 

Structure literals 

Structure field assignment 

(setf field-selector expression) 

Structure field selectors 

Structure element values are selected by means of selector forms that DEFTYPE creates. The 
name of the form is the name of the field. ??can't be that simple, need to explain INCLUDE in 
here too?? 

Pointers 

Forms for making and testing pointers are provided. 

Bake-pointer type-name value Special Form 

Returns a pointer of type type-name pointing at value, value must be coercible to the 
type pointed to by type-name. 

»ake-nall-p6lnter type-name Special Form 

Returns a pointer of type type-name pointing at nothing. All null pointers have the same 
value, so they may be compared and used as flags. 

null pointer-value 

Returns true if pointer-mlue ]s a null pointer, false otherwise. 
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Functions 

Functions must be declared at top level with DEFUN. For a multiple value return, the function 
declaration must specify the types for the values being returned. 

You can have several different functions with the same name, provided that the formal parameter 
lists do not have the same types for parameters in conesponding positions. The type of a 
function is determined by ??does the concept of a function type fit here?? So two functions are 
the same type if they have formal parameters with the same types. 

Unlike Lisp, you can use RETURN to return none, one, or multiple values from a function. 

Formal syntax for functions 

function-declaration v,^ (DEFUN name-spec parm-list body) 

name-spec ::- { name | (name type-id 1 . typeids )} 
parm-list ::= (parm-declarations) 

parm-declarations ::= (identifier type-id . options) 

options ::= (MODE { VALUE ] REF } ) 

Function variables 

??function variables should have a type?? 

function function-name Special Form 

Returns a THTTn to function-name. 

fnncall function &rest orgs 

Calls function with orgs. This form will not return a value. 

Prog Forma 

As in Lisp, LIL has a prog facility. A prog is a construct that is used for its effect rather than 
for its value and that h used for altering flow of control 

In spite of the fact that it is designed to be executed for effect, a prog can return a value, either 
using RETURN or by falling out the bottom (depending on the kind of prog). 

For controlling flow of control, some prog forms can include labels and unconditional jumps 
(gotos) to labels. In addition, RETURN provides a mechanism for leaving the body of prog by 
some means other than falling out the bottom. This is like a break out of a block in a block- 
structured language. 

LIL provides the following set of prog variants, as in Lisp. 

PROG Does not return a value unless a RETURN that returns a value is encountered. 

Can include unconditional jumps {GO) to a label. Can include local variable 
declarations. 

<30 Within a PROG, jumps to the specified label. 

RETURN Within a PROG (or DO or LOOP), leaves the PRCXj body immediately and 

makes the specified value the value of the PROG. 

PROGN Returns the value of the last form evaluated. 

PR(X31 Returns the value of the first form evaluated. 

PROG2 Returns the value of the second form evaluated. 
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Formal syntax for progs 

prog ::- { (PROG 

prog-declaration-list 

prog-body) | 

( {PROGN I PROGl 1 PROG2 } 
prog-body) } 

return-form ::= (RETURN expressions) 
Conditionals 

LIL has the. standard Lisp conditional structures, IF, COND, AND, and OR. The $emantics are 
as in Lisp. 

LIL has SELECT and SELECTQ constructs for conditional execution. SELECTQ allows you to 
select an alternative based on an expression that is a compile-time constant. SELECT works on 
expressions that are evalutated at run time. 

Formal syntax for conditionals 

conditional-expression ::= { if-expression | 

cond-expression | 
and-expression | 
or-expression | 
select-expression } 

Iteration 

LIL has two main iteration constructs, LOOP and DO. 

Functions and Special Forms Involving Types 

Several forms allow manipulation of LIL types. Their behavior is similar to that of Lisp special 
forms in that type names must be specified. Since LIL is strongly typed, there is no notion of 
run-time tj'ping. 

type-size type-name Special Form 

The number of bytes allocated for objects of type type-name 

trray-length value 

The number of elements in value. The type of value must be some array type. 

structare-offset slot-name type-name Special Form 

The distance in bytes from the beginning of objects of type type-name to the beginning of 
slot-name, 

coerce type-name valve Special Form 

valve treated as typt type-name. 

default-type value Special Form 

This form gives a specific type to a generic number. The type chosen is the smallest 
"machine type" which will hold value. If value has a type already, the result is simply 
value, 

constant type-name &rest orgs Special Form 

type must be either an array or structure type. A value of type type-name is created with 
values filled in as specified. For a structure, args are pairs of slot names and values. For 
an array, args is simply a hst if values. Each value specified must itself be constant. 
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(constant struct-1 

slot-1 123 

slot-Z 456 

slot-3 (constant array-l 0)) 

(constant array-l 12 3 4 5) 

10 - PAL 
SCRC:<LMI0B>BI-PHASE.PAL;4 

;-«- nod«:LISP; P»ck»5«:USER; Bate:10 -»- 

t; Bi-phata decodar pal for tha conaote link 

(DEFPAL Bl -PHASE PAL16R8 
i pin 1 is 4,3152 riHz clock 
(IPIN 2. ENCODED- INPUT) 

(RPIN 19 R)(D-SYNC) 
(RPIN 18 RXD-DLY) 
(RPIN 17 TRANSITION) 
(RPIN IG SEQUENCER) 
(RPIN 15 RCV-CLK) 
(RPIN 14 riASIC) 
(RPIN 13 SAMPLE) 
(RPIN 12 DECODED-OUTPUT) 

(SETQ R)(D-SY?C ENCODED- INPUT) ;Synchronize input data to local clock 

(SETQ RXD-OLY R)(D-SYNC) tSecond-half of aynchponizer 

(SETQ TRANSITION (XOR R)(D-SYNC RXD-OLY)) sedge detector 

(SETQ SEO^NCER (AND (NOT ttASJC) (OR TRANSITION SEQUENCER))) ; Start sequence 

(SETQ RCV-a< (NOT SEQUENCER)) : recovered clock 

(SETQ rUSK (NOT RCY-CLIC)) tMsk out aid-bit transitions 

.SETQ SA«^ (COND ((AND f^NCER^«eE^,-CL,^^.«XD-XV^^^^ Hr.t Half .at, 

(SETQ DECOOED-OUTPUT (C(DND ((AND RgMXK^.^.)^(XOf,^ 'Sic^O^^lghM^^" —• '^ '^^^' 
$; end of def ini tion 
SCRC : <LMIOB>CACCTL . PAL ; 1 

;-»- node:LISP; Packaaa:USER; BASE: 10 -«- 

;PAL For controlling the two word "cache" at the LBUS interface to the 
;TY neeorg on the REV-3 I/O board. PAL appears on dwg. CACCTL.DUG. 

(DEFPAL CACCTL PAL16RS 

{ (INPIN 1 -LB STATE CLOCK) 

(IPIN 2 CPU-DATA-CYaE L) 
(IPIN 3 CPU-URITE-On L) 
(IPIN 4 CPU-URITE) 
(IPIN 5 LB-URITE L) 
(IPIN 6 LB-ADDR-00) 
(IPIN 7 CPU-ADDR-00) 
(IPIN 8 L0-TV-REQ L) 
(IPIN 9 CACHE-HIT L) 

(OPIN IS CACHE-ACT-EN L) 

(RPIN 18 ODD-CACHE-URITE) 
(RPIN 17 ODD-OE L) 
(RPIN 16 EVEN-OE L) 
(RPIN 15 CACHE-DIRTY L) 
(RPIN 14 EVEN-CACHE-URITE) 
(RPIN 13 CACHE-ACTIVE-CYCLE L) 

(SETQ EVEN-CACHE-URITE (AND LB-TV-REQ CACHE-HIT LB-URITE (NOT LB-ADDR.00) 

(NOT CACHE-DIRTY))) 

(SETQ CACHE-DIRTY (OR (AND CACHE-HIT LB-TV-REQ LB-URITE (NOT LB-AOOR-00) 

(NOT CACHE -DIRTY)) 
(AfC CACHE-DIRTY (NOT CPU-URITE-OM))) 

(SETQ CAC^€ -ACTIVE-CYCLE (OR (AND CACHE-HIT LB-TV-REQ (NOT LB-AODR-00) LB-URITE 

(NOT CACHE-DIRTY)) 
(AND CACHE-HIT LB-TV-REQ (NOT LB-URITE) (NOT CACHE-DIRTY)))) 
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CSETQ EVEN-Oe (OR (AND CACHE-ACTIVE-CYCLE (NOT CPU-ADOR-09) (NOT CPU-URITE)) 
(AND CPU-OATA-CYCLE (NOT CPU-ADDR-eS) (NOT CPU-URITE)))) 

(SETI2 OOO-OE (OR (AND CACf€-ACTIVE-CYCLE (NOT CPU-ADOR-08) (NOT CPU-URITE)) 
(AND CPU-DATA-CYCLE CPU-ADDR-e8 (NOT CPU-URITE)))) 

(SETQ CACHE-ACT-EN (OR (AND CACHE -HIT LB-TV-REQ (NOT LB-ADOR-88) LB-URITE 

(NOT CACHE-DIRTY)) 
(AND CACHE-HIT LB-TV-REQ (NOT LB-URITE) (NOT CACHE-DIRTY)))) 

:;ENO OF DEFINITION 



SCRC : <LHIOB>DDROE , PAL : 6 

;-«- node:LISP; Package:USER; BASE:18 -«- 

;PAL For control ling Displau Data Register output enables and the register select 
; inputs to the An29S20*s. Pal appears on dwg. FIFCTL.DUG, 

(DEFPAL DDROE PAL16L8 

(IPIN 4 TV-Dn-ACTIVE-A L) -NOT USED 

(IPIN 5 FILL-ADDR-03) NOT USED 

(IPIN S FILL.ADDR-82) ' 

(IPIN 7 FILL-ADDR-ei) 

(IPIN 8 FILL-ADDR-88) 

(IPIN 9 FILL-GO) 

(IPIN 11 OOD-CHUNK-COUNT-A L) ,NOT USED 

(OPIN 16 DDR-0E.3 L) 
(OPIN 15 DDR-OE-2 L) 
(OPIN 14 DDR-OE-1 L) 
(OPIN 13 DDR-OE-8 L) 
(OPIN IS DOR-PIPE-S-1) 
(OPIN 12 DOR-PI PE-S-0) 

(FIELD REG-ADDRESS FILL-ADDR-Bl FILL-ADDR-80) 

(SETQ OOR-OE-8 (AND FILL-GO (FIELD REG-ADDRESS 8)1) 

(SETQ DOR-OE-1 (AND FILL-GO (FIELD REG-ADDRESS 1))) 

(SETQ DOR-CE-2 (AMD FILL-GO (FIELD REG-ADDRESS 2))) 

(SETQ DDR-OE-3 (AND FILL-GO (FIELD REG-ADDRESS 3))) 

(SETQ DDR-PIPE-S-8 (AND FILL-t^ (NOT FILL-ADDR-82))) 

(SETQ DOR-PIPE-S-l (AND FILL-GO FILL-ADOR-82)) 

jjEND OF DEFINITION 

SCRC: <LMIOB>DKSER . PAL ; 3 

: -»- node:Lisp; Package:User; Base:18 -«- 
; PAL for disk serial data paths control 
(DEFPAL DKSER PAL1SL8 
a \l 'Eh^.^t'.ll^'^' '^"-'"^ "-=• Of ind../.ector 

(OPIN 14 ECC-XOR-l^ITE) 

(OPIN 12 DISK-FROn-riEn L) 

(IPIN 18 DIS»C-START.BL0C<-SYNC2) 
(IPIN 17 DISIC-START-BL0CK-SYNC3) 

{{pit! h P^P^^nR^P^^^^ n '°3*3 ^'t ^^°'" disk 

P N 7 mQ^^Qi^niiTi •§'* °"^ °^ ^CC register 

IIPIN 3 DISK-SH-OUT) jOata bit to disk 

({pIN 5 U^DATA-RELD) jRegister output for read conpare flag 

(IPIN S dFsK-START) iState Machine start inn 

(IPIN 7 DISK-COnnAND-3) State Sach nS SroaraS^seliict 
(IPIN 8 DISK-COnnAND-2) ■acnine program select 

(IPIN 9 DI5<-C0nnAN0-l) 
(IPIN 11 DISK-COnnAND-8) 

(FIELD OIS»<:-COmAND DIS»C-C0nnAND-3 DISIC-COnnAND-2 OISK-COmAND-l DIS>C.C0tinAND-8) 
(AND (NOT OISK-READ-DATA) EGC-OUT))) 
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(SETQ ECC-XOR-URITE (OR (AND DISK-SH-OUT (NOT ECC-OUT)) 

(AND (NOT DISK-SH-OUT) ECC-OUT))) 

;: Set READ-COTIPARE tf disk and nemopy data differ; clca'^ at startup 
(SeTQ DATA-DIFFEREWCE (AND U-DATA-FIELD 

(OR (AND D I SIC-READ-DATA (NOT DISK-SH-OUT)) 
(AND (NOT DISK-READ-DATA) DISK-SH-DUT) )) ) 
(SETQ NEXT-READ-COnPARE (AND (NOT DIS<-START) 

(OR READ-COttPARE DATA-DIFFERENCE) )) 

;;— - Opcodes 8-7 am reads, 18-17 are urites 

;;™ ipnore unused inputs error. 

(§ETQ DISK-FROn-nEn"(FIELd_OIS<-COnnAND tfode 11 12 13 14 15 16 17)))) 

SCRC : <LMI0B>DICSTM2 . PAL ; 3 

{ -«- flodetLisp; Package: User; BaBe:18 -«- 

; PAL for disk state aachine 

(DEFPAL DICSTn2 PAL1SL8 

(OPIN 14 ECC-2ER0) tStatus flag 

(DPIN 13 NEXT.STATE-8) ;Skip bit oT proe address 

(OPIN 13 SET-DIS<-ERROR L) iDirect Set error flip flop 
(OPIN 12 DISK-DONE L) ;Clocked Clear id)e fiip ffop 

(IPIN 18 ECC-ZERO-O) jECC bits tested for zero 5 at a time 

(IPIN 17 ECC-2ER0-C) 

(IPIN IS ECC-ZERO-B) 

(IPIN IS ECC-ZERO-A) 

(IPIN 1 ECC-U) ;One left-over ECC bit 

(IPIN 2 PADDLE-SELECT-ERROR) ;Di8k select status 

(IPIN 3 ADVANCE-STATE L) jState aachine advancing this clock 

(IPIN 4 OVERRUN) lError status 

(IPIN 5 DISK-START-BLOCK) ^Error status 

(IPIN 6 DISK -END-FLAG) {Condition from L machine 

(IPIN 7 NEXT-STATE-C7L-11 tField controESing NEXT-STATE-0 

(IPIN 8 NEXT-STATE-CTL-8) 

(IPIN 3 U-FUNC-1) iDISK-OONE/error control field 

(IPIN 11 U-FUNC.8) 

(FIELD NEXT-CTL r€XT-STATE-CTL-l NEXT-STATE-CTL-0) 
{0 output 
tl output 1 

;2 output DISK-END-FLAG 
;3 (not used) 

(FIELD U-FUNC U-FUNC-1 U-FUNC-8) 
$0 nothing 
jl stop \f ecc«0 
;2 error if DISK -ST ART-BLOCK 
;3 stop 

(SETQ ECC-2ER0 (AND ECC-ZERO-A ECC-ZERO-B ECC-ZERO-C 
ECC-ZERD-D (NOT ECC-11))) 

(SETQ NEXT-STATE.0 (OR (FIELD NEXT-CTL 1) 

(AND (FIELD NEXT-CTL 2) DISK-END-FLAG))) 

(SETQ SET-DISK-ERROR (OR OVERRUN PADOLE-SELECT-ERROR 

(AND (FIELD U-FLtfC 2) DISK-START-BLXK))) 

(SETQ DISK-DONE (OR (AND (FIELD U-FUNC 1) ECCZERD) 

(AND (FIELD U-FUNC 3) ADVANCE-STATE)))) 

SCRC:<LMI0B>FIFCTL.PAL:5 

l-«. floderLISP; Package:US£R; SASE:18 -*- 

;PAL For controlling the RATI FIFO. Pal appears on dwg* FIFCTL.DUG. 

(DEFPAL FIFCTL PAL1BR4 

: (IPIN 1 PIXEL CLK/4 L) ;€LDCK INPUT 
; (IPIN 11 GND) lOUTPUT ENABLE 

(IPIN 18 TV-On-ACTIVE-A L) 
(IPIN 13 STROBE-A) 
(IPIN 12 S+60-NS-A) 
(IPIN 2 LAST-CHUNK L) 
(IPIN 3 ODD-CHUNK-COUNT-A L) 
(IPIN 4 FILL-GO) 
(IPIN 5 FIFO-REQ+12) 
(IPIN 6 FILL-ADDR-83) 
(IPIN 7 FILL-ADDR-82) 
(IPIN 8 FILL-ADDR-01) 
(IPIN 3 FILL-ADDR-00) 



4,887,235 
1123 1124 

(RPIN 17 DRAIN-CNT-EN L) 
(RPIN IS FILL-CNT-EN L) 
(RPIN 15 FIFO-URITE L) 
(RPIt^ 14 LD-VSR L) 

COPIN 19 FILL-GO-EN) 

(FIELD REG-ADDRESS FILL-ADOR-02 FILL-ADE^-Bl FJLL-ADDR-ae) 
;The DTD registers have been loaded with fresh data. Start a FIFO stuff cycle* 

(SETQ Fia-GO-EN (OR (AND S4€0-NS-A (NOT FILL-GO)) 

(AND FILL-GO (NOT LAST CHUNK) (NOT (FIELD REG-ADDRESS 7))) 

{This is the last chunk and the chunk count uas even so ue go ahead and load the odd one. 

(AND FILL-GO LAST-CHUNJC (NOT OOO-CHUNK-COUNT) 
(NOT (FIELD REG-ADDRESS 7))) 

:Thi8 (8 the last chunk and the count uas odd so ue do not load the odd one* 

(AND FILL-GO LAST-CHUWC ODD -CHUNK -COUNT (NOT (FIELD REG-ADDRESS 3))))) 

;Uhcnever the FIFO request uants it, it gets it. 

(SETQ DRAIN-CNT-EN FIFO-REQ+IZ) 

;FiII go enable is asserted and the FIFO request ta not happening so ue ■ight as uell 
sstart the cgcle now. 

(SETQ FILL-CNT-EN (OR (AND FILL-GO-EN (NOT FIFO-REQ+12)) 

; Increment te fill count. 

(AND FILL-GO (NOT FIFO-REQ+12) (NOT LAST -CHUNK)) 

jUe are at the end of a line but this is the even half of the last cgcle so that ue can 

:go angwag. ' 

(AND FILL-GO (NOT FIFO-REQ+12) (NOT FILL-ADDR-02) 

LAST-CHUNK) 

:Ue are at the end of a line, the odd half of th% cycle, and it is not Mn odd chunk count. 

(AND FILL -GO (NOT FIFO-REQ+12) LAST-CHUNK FILL.ADDR-02 
(NOT ODD-CHUNK -COUNT) ) 

jSomething is wrong. The counter should always be at REG-AOORESS when FILL GO is not 
;asserted. Increment it till this is true. 

(NOT-FILL-GO) (NOT (FIELD REG-ADDRESS 0))) 
:dra?n'i^g!^ a I wags happens when you are filling. It never happens when you are 

(SETQ FIFO-URITE (OR (AND FILL-GO-EN (NOT FIFO-REQ+12)) 
(AND FILL-GO (NOT FIFO-REQ+12)))) 

;After you enable the drain count you load the VSR. Pipe delays. 

(SETQ LD-VSR DRAIN-CNT-EN) 

j:ENO OF DEFINITION 
SCRC:<L«0B>LBDMA1,PAL;6 

;-«- riodeiLISP; PackagerUSER; Base: 10 -«- 

fi^ dS«inirLB03A"'*"'°'^''''" "'''*• '"«0'»^«'"» ^°^ P«"^o registers) 

'ff^- **S''i"/°" u*® *'°?'"? *•!?" i?P • wicrodevice write address space of 

:?k:^ "•:!*«• a 'ask end wnte or any combination of the three in 
( xne saee wr i to. 

;It is convenient also for reading the net buffer register to have this 
f iw\ I xuoe 

(DEFPAL LBDMAl PALISLS .PAIIKIRA 

(IPIN 1 LB-RESET L) .rALibLSA 

(IPIN 2 LB-URITE) 
(IPIN 3 LB-DEV-4) 
(IPIN 4 LB-DEV-3) 
(IPIN 5 LB-DEV-2) 
(IPIN 6 LB-DEV-1) 
(IPIN 7 LB-DEV-0) 
(IPIN 8 LB-DEV-READ) 
(IPIN 9 LB-DEV.URITE) 
(IPIN 11 DEVICE-PtATCH L) 
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(OPIN 18 DISIC.DnA-RQ-CYCLE) 
(OPIN 17 DISK-DISniSS) 
(OPIN IB DISK-ENO) 
(OPIN 15 disk:-tas<-ac<) 

(OPIN 14 NET-OnA-RQ-CYCLE) 

(OPIN 13 f€T.DISniSS) 

(OPIN 19 NET-END) 

(OPIN 12 Df1A.T0-r€n-RQ-CYCLE} 

(FIELD DEVICE-ADDRESS LB-DEV^ LB-DEV-3) 

(SETQ LB-DEV-CYCLE (OR LB-DEV-READ LB-DEV-URITE)) 

;i^p«r tuo bits specify uhich devlca gou're talking to 

; 01-— fiet 
; 18— pio 

I ll~vd 

(SETQ DISIC-SELECT (AND (FIELD DEVICE-ADDRESS 8) DEVICE-HATCH)) 

(SETQ «T-SELECT (AND (FIELD DEVICE-ADDRESS 1) DEVICE-TIATCH)) 

(SETQ PIO-SELECT (AND (FIELD DEVICE-ADDRESS 2) DEVICE-ttATCH)) 

;lou«r three bits specify the function 

(FIELD DEV-OP LB-DEV.2 LB-OEV-1 LB-OEV-8) 

DISK FUNCTIONS 

8 write disk buffer directly (rev 2 end later) 

1 dma cycle (start dna cycle without dismissina) 

2 dismiss, task acknowledge (just clear wakeupf 

3 dismiss $> dtra cycle 

4 disnisft (only) 

5 ki I I disk task 

6 diseiss, task acknowledge, eet end flag 

7 daa cycle & set end flag « disniss 

(SETQ DISIC-DflA-RQ.CYCLE (AND DISK-SELECT LB-DEV-URITE (FIELD DEV-OP (13 7)))) 

(SETQ DISK-DISniSS (OR LB-RESET 

(AND DISK-SELECT LB-DEV-URITE (FIELD DEV-OP (2 3 4 S 6 7))))) 

(SETQ DISK-END (AND DISK-SELECT LB-DEV-URITE (FIELD DEV-OP (B 7)))) 

(SETQ DISK-TASK-ACK (AND DISK-SELECT LB-DEV-URITE (FIELD DEV-OP (2 B)))) 

;NET FUNCTIONS 

I bit DHA 

; bit 1 Disaiss 

t bit 2 End 

(SETQ >ET-DnA-RQ-CYCLE (AND NET-SELECT LB-DEV-CYCLE LB-DEV-8)) 

(SETQ rCT-DISniSS (OR LB-RESET (AND NET-SELECT LB-DEV-CYCLE LB-DEV-1))) 

(SETQ >CT-ENO (AND NET-SELECT LB-DEV-CYCLE LB-DEV-2)) 

:PIO functions same as NET 

(SETQ PIO-DnA.RQ-CYCLE (AND PIO-SELECT LB-DEV-URITE LB-DEV-8)) 

(SETQ OriA-TO-nEn-RQ-CYCLE (AND (OR DISK-OflA-RQ-CYCLE NET-DflA-RQ-CYCLE) 

LB-URITE)) 
;;; end of def ini tion 

SCRC : <LMI0B>LBDMA2 . PAL ; 7 

t-»- floderLISP; Package:USER; Bass:18 -»- 

•'(tn d^'a ^•^•^|*InjLf'*^''°^*^'^* write registers (or pseudo registers) 

;Each device on the board takes up a microdev^ce write address space of 

'l^mcM?ce' ^?i^^* ^??e5*ir^^* .^^» ^^^^ *^*^ ^« at)le to do a DHA write, 
;a DISniSS write, a TASK END wrrte or any combination of the three in 
; the same ur i te. 

(DEFPAL LBDnA2 PAL16L8 -PALieLSA 

(IPIN 1 LB-RESET L) ,^'ALlbL5A 

J (IPIN 2 LB-URITE) ,NOT USED 

(IPIN 3 LB-DEV-4) 
(IPIN 4 LB-DEV-3) 
(IPIN 5 LB-DEV-2) 
(IPIN 6 LB-DEV-1) 
(IPIN 7 LB-DEV-8) 
(IPIN 8 LB-DEV-READ) 
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(fPIN 9 LB-DEV-URITE) 
(IPIN 11 DEVICE-riATCH L) 

(OPLN 17 AUDIO-DISflISS) 

(CFIN 15 VD-DISnrSS L) 

(OPIN 13 DISK-niCRODEVICE-URITE) 

;PINS 14.16,18 SPARE 

(OPIN 19 DEV-READ-CYCLE) 
{OPIN 12 DEV-UR I IE-CYCLE) 

(FIELD DEVICE-ADDRESS LB-DEV-4 LB-DEV-3) 

(SETQ DEV-URITE -CYCLE (AND OEViCE-nATCK LB-DEV-URITE)) 

(SETQ DEV-READ-CYCLE (AND DEVICE-HATCH LB-DEV-READ) ) 

^'?&*Ta'^fl5!R§''l^^!ilM*^^^^^^ °^'"^'^' ^' ^^ °^ ^"^ 

(SETQ DISniSS-RQ (AND LB-DEV-1 LB-DEV-URITE)) 

(SETQ DTIA-RQ (AND LB-OEV-8 LB-DEV4JRITE)) 

jpper two bit* specify which device youVe talking to 

81 net 

18 — audio 
11 — vd 

(SETQ VD-SELECT (AND (FIELD DEVICE-ADDRESS 3) DEVICE-flATCH)) 
(SETQ AUDIO-SELECT (AND (FIELD DEVICE-ADDRESS 2) DEVICE-HATCH)) 

(SETQ AUDIO-DISniSS (OR LB-RESET (AND AUDIO-SELECT DISHISS-RQ))) 

(SETQ VO-DISniSS (OR LB-RESET (AND VD-SELECT DISniSS-RQ))) 

(SETQ DIS>C-niCRODEVICE.URITE (AND DEV-URITE-CYCLE (FIELD DEVICE-ADDRESS 8))) 

:;; end of def ini tion 

SCRC : <LHI0B>LBDMA3 , PAL : 10 

t-*- node:LISP; Package:USER; 6aae:18 -«- 

;PAL For selecting »icPOdevice write registers (or pseudo rcoistera) 
;(m drawings LBDnA) 

(OEFPAL LB0nA3 PAL1EL8 jPALlSLSA 

(IPIN 1 LBUS-ID-REQUEST L) 
(IPIN 2 SLOT-ADDR-riATCH L) 
(IFIN 3 LB-.DEV-4) 
(IPIN A LB-DEV-3) 
(IPIN 5 LB-OEV-2) 
(IPIN 6 LB-OEV-1) 
(IPIN 7 LB-DEV-B) 
(IPIN 8 LB-DEV-READ) 
(IPIN 9 LB-DEV-URITE) 
(IPIN 11 DEVICE-HATCH L) 

(OPIN 19 <ILL-DIS<-TAS)C L) 
(OPIN 18 READ-DISK -BUF L) 
(OPIN 17 READ-NET-BUF L) 
(OPIN 16 URITE-NET-UBC) 
(OPIN 15 URITE-DISK-BUF L) 
(OPIN 14 URITE-NET-BUF L) 
(OPIN 13 URITE-AUDIO-BUF) 
(OPIN 12 lO-REAO-CVaE) 

(FIELD DEVICE-ADDRESS LB-DEV-4 LB-DEV-3} 

(FIELD DEVICE-OP-COOE LB-DEV.2 LB-OEV-1 LB-0EV-8J 

lugper two bits specifg which device you're talking to 

; 81 net 

J 18 — audio 

; 11 — vd (except for write net wbc — see below) 

(SETQ DIRECT-OEV-URITE-CYCLE (AND DEVICE-HATCH LB-DEV-URITE 

(FIELD DEVICE-OP-CODE 8))) 

(SETQ DIRECT-DEV-READ-CYCLE (AND DEVICE-HATCH LB-DEV-READ 

(FIELD DEVICE-OP-CODE 8))) 

(SETQ DIRECT-fCT-READ-CYCLE (AND DEVICE-HATCH LB-DEV-READ)) 

(SETQ DIRECT-NET-URITE-CYCLE (AND DEVICE-HATCH LB-DEV4JRITE)) 
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(SETQ REAO-DISJCBUF (AND (FIELD DEVICE-ADDRESS 0) DIRECT-DEV-READ-CYCLE)) 
(SETQ REAO-NET-BUF (AND (FIELD DEVICE-ADDRESS 1) DIRECT-NET-READ-CYCLE)) 

(SETQ URITE-DISK-BUF (AND (FIELD DEVICE-ADDRESS 0) DIRECT-DEV-URITE-CYCLE)) 
(SETQ URITE-NET-BLF (AND (FIELD DEVICE-ADDRESS 1) OIRECT-fCT-URITE-CvaE)) 

;; IfLUDGE 

(SETQ URITE-NET-UBC (AND (FIELD DEVICE-ADDRESS 3) DIRECT-OEV-URITE-CVaE)) 

(SETQ URITE-AUDIO-BUF (AND (FIELD DEVICE-ADDRESS 2i DIRECT-OEV-URITE-CYCLE)) 

(SETQ ID-READ-CYCLE (AND LBUS- ID-REQUEST SLOT-ADDR-ttATCH)) 

(SETQ KILL-OISK-TASK (AND (FIELD DEVICE-ADDRESS 0) DEVICE-MATCH LB-DEV-URITE 

(FIELD DEVICE-OP-CODE 5))) 

:;; end of def ini t ion 

SCRC:<LMIOB>LBMI01.PAL:4 

j-«- ModetLISP; PackagetUSER; Base:10 -«- 

;PAL Fop taltcting aewory-aapped registers for reading (in dpawinge LBniO) 

(DEFPAL LBfllOl PALIBRS 
(IPIN 2 LB-ADDR-18) 
(IPIN 3 LB-ADDR-17) 
(IPIN 4 LB-ADDR-3) 
(IPIN 5 LB-ADDR-2) 
(IPIN 6 LB-ADDR-1) 
(IPIN 7 LB-ADDR-0) 
(IPIN 8 lO-READ-ACTIVE-CYCLE) 
(IPIN 9 lO-READ-RQ) 

(RPIN 19 READ-DIS»C-COnnAND L) 
(RPIN 18 READ-DISK-ECC L) 
(RPIN 17 READ-DISIC-STATUS L) 
(RPIN 16 READ-DISK-RPS L) 
(RPIN 15 READ-NET-STATLTS L) 
(RPIN 14 READ-VD-STATUS L) 
(RPIN 13 READ-VD-DIAG L) 
(RPIN 12 READ-PA0DLE-EN8 L) 

(FIELD REG-ADDR LB-ADDR-3 LB-AODR-2 LB-ADDR-1 LB-ADDR-8) 

(SETQ REG-READ-RQ (AND (NOT LB-^ADDR-IS) (NOT LB.ADOR-17) lO-READ-RQ)) 

(SETQ REAO-DISIC-COnriAND (OR (AND REG-READ-RQ (FIELD REG-ADDR 0)) 

(AND lO-REAO-ACTIVE-CYCLE READ-DISK-COnnAND) ) ) 

(SETQ READ-DISIC-ECC (OR (AND REC-REAO-RQ (FIELD REG-ADDR D) 

(AND I Q-REAO- ACTIVE-CYCLE READ-DISK-ECCI ) ) 

(SETQ READ-DISK-STATUS (OR (AND REG-READ-RQ (FIELD REG-ADDR 2)) 

(AND lO-READ-ACTIVE-CYCLE READ-DISK-STATUS))) 

(SETQ READ-OISIC-RPS (OR (AND REG-READ-RQ (FIELD REG-ADDR 3)) 

(AND lO-REAO-ACTIVE-CYCLE READ-DISK-RPS))) 

(SETQ READ-NET-STATUS (OR (AND REG-READ-RQ (FIELD REG-ADDR 4)) 

(AND lO-READ-ACTIVE-CYCLE REAO-NET-STATUS)) ) 

(SETQ READ-VD-STATUS (OR (AND REG-READ-RQ (FIELD REG-ADDR 6)) 

(AND lO-READ-ACTIVE-CVaE READ-VD-STATUS))) 

(SETQ READ-VD-DIAG (OR (AND REG-READ-RQ (FIELD REG-ADDR 7)) 

(AND lO-READ-ACTIVE-CVaE READ-VD-DIAG))) 

(SETQ READ-PADDLE-ENB (OR (AND REG-READ-RQ (FIELD REG-ADDR 8)) 

(AND lO-READ-ACTIVE-CYCLE READ-PADDLE-ENB))) 

;; end of def tni tion 

SCRC : <LMI0B>LBMI02 . PAL : 4 

;-»- node:LISP; Package:USER; Base:10 -«- 

iPAL For selecting »enory-«apped registers for reading (in drawings LBTIID) 

(DEFPAL LBni02 PALIBRS 
(IPIN 2 LB-ADOR-18) 
(IPIN 3 LB-ADDR-17) 
(IPIN 4 LB-ADDR-3) 
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<IPIN 5 LB-ADDR-2J 

(IPIN 6 LB-ADDR-l) 

(IPIN 7 LB-ADDR-8) 

(IPLN 8 lO-READ-ACTIVE-CYCLE) 

(IPIN 9 lO-REAO-RQ) 

(RPIN 13 READ-PIO-DATA L) 
{RPIN 12 REAO-PIO-STATUS L) 

(FIELD REG-ADOR LB-AXR-3 LB-ADOR-2 LB-AOOR-1 LB-ADOR-0} 

(SETQ REG-REAO-RQ <AND (NOT LB-ADDR-18) (NOT LB-AODR-17) lO-READ-RQ)) 

(SETQ READ-PIO-STATUS (OR (AND REG-READ-RQ (FIELD REG-ADDR 9.)) 

(AND lO-REAO-ACTIVE-CYCLE READ-PI O-STATUS) ) ) 

(SETQ READ-PIO-DATA (OR (AND REG-REAO-RQ (FIELD REG-ADOR 18.)) 

(AT^J lO-REAO-ACTIVE-CYCLE READ-PIO-OATA) ) ) 

;; end of daf ini tion 

SCRC : <LMI0B>LBMI03 , PAL ; 3 

;-«- riode:LISP; PackageiUSER; Base: 10 -»- 

;PAL For te I acting ••«opy-«apped ragitteri for writing Cin drawings LBHIOi 

(DEFPAL LBni03 PAL16R8 

(IPIN 2 LB-ADDR-18) 
(IPIN 3 LB-ADDR-17) 
(IPIN 4 LB-ADDR-3) 
(IPIN 5 LB-ADDR-2) 
(IPIN 6 LB-ADDR-1) 
(IPIN 7 LB-ADOR-0> 
;: 8 spare 



Spi 

(IPIN 9 lO-URITE-RQ) 

(RPIN 19 URITE-DIS<-COnnAND L) 

(RPIN 18 URITE-DISK-DIAG L) 

(RPIN 17 URITE-NET-DIAG L) 

(RPIN 16 URITE-NET-CNTRL L) 

(RPIN 15 URITE-VD-CNTRL L) 

(RPIN 14 URITE-PIO-CNTRL L) 

(RPIN 13 URITE-PIO-DATA L) 

(RPIN 12-URITE-PADDLE-ENB L) 

(FIELD REG-ADOR LB-AOOR-3 LB-AOOR-2 LB-ADDR-1 LB-AODR-0) 

(SETQ REG-URITE-RQ (AND (NOT LB-AEDR-IS) (NOT LB-ADDR-17) lO-URlTE-RQ)) 

(SETQ URITE-DISK-COnriAND (AND REG-URITE-RQ (FIELD REG-ADOR 0))) 

(SETQ URITE-DISK-DIAG (AND REG-URITE-RQ (FIELD REG-ADDR 2>)) 

(SETQ URITE-NET-CNTRL (AND REG-URITE-RQ (FIELD REG-ADDR 4))) 

(SETQ URITE-NET-DIAG (AND REG-URITE-RQ (FIELD REG-ACDR 5))) 

(SETQ URITE-VD-CNTRL (AND REG-URITE-RQ (FIELD REG-ADOR B))) 

(SETQ URITE-PADDLE-ENB (AND REG-U?ITE-RQ (FIELD REG-ADDR 8.))) 

(SETQ URITE-PIO-CNTRL (AND REG-URITE-RQ (FIELD REG-ADOR 9.))) 

(SETQ URITE-PIO-DATA (AND REG-URITE-RQ (FIELD REG-ADDR 10.))) 

; ; end of def ini t ion 
) 

SCRC:<LMI0B>LBMI0R.PAL;5 

;-*- node:LISP; Package:USER; Base: 10 -«- 

;PAL For telecting MBoru-Bapped regittert for reading (in drawings LBHIO) 

(DEFPAL LBniOl PALieR8 
(IPIN 2 LB-ADDR-18) 
(IPIN 3 LB-ADDR.17) 
(IPIN 4 LB-ADDR-3) 
(IPIN 5 LB-ADDR-2) 
(IPIN 6 LB-ADDR-l) 
(IPIN 7 LB-ADDR-0) 
(IPIN 8 lO-READ-ACTIVE-CYCLE) 
(IPIN 9 lO-READ-RQ) 

(RPIN 19 READ-DISJC-COnnAND L) 
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(RPIN 18 ffEAD-Drs^r-Ecc: u 

(RPIN 17 READ-DISK-STATUS L) 
(RPIN 18 READ-DI5<-RPS L) 
(RPLN 15 REAO-NET-STATUS L) 
(RPIN 14 READ-VD-STATUS L) 
(RPIN 12 REA0-PA0DLE-EN8 L) 

(FIELD REG-ADDR LB-ADOR-3 LB-A00R.2 LB-ADOR-1 LB-ADDR-0) 

(SETQ REG-REAO-RQ (AND (NOT LB-AOOR-IS) (NOT LB-AODR-17) lO-REAO-RQ)) 

(SETQ READ-DISJC-COnrtAND (OR (AND REG-READ-RQ (FIELD REG-ADDR 0)) 

(AND lO-REAO-ACTIVE-CYCLE REAO-DISK-COmAND) )) 

(SETQ READ-OIS<-€a: (OR (AND REG-READ-RQ (FIELD REG-ADDR D) 

(AND lO-REAO-ACTIVE-CYCLE REAO-OISK-ECC))) 

(SETQ READ-DISK-STATUS (OR (AND REC-REAO-RQ (FIELD REG-ADDR 2)) 

(AND lO-REAO-ACTIVE-CYCLE REAO-DISK-STATUS))) 

(SETQ READ-OISIC-RPS (OR (AND REG-READ-RQ (FIELD REG-ADDR 3)) 

(AND lO-REAO-ACTIVE-CYCLE READ-DISK-RPS)) ) 

(SETQ READ-NET-STATUS (OR (AND REG-READ-RQ (FIELD REG-ADDR 4)) 

(AND lO-REAO-ACTIVE-CYCLE READ-NET-STATUS))) 

(SETQ READ-VO-STATUS (OR (AND REG-REAO-RQ (FIELD REG-AOOR B)) 

(AND lO-READ-ACTIVE-CYCLE READ-YD-STATUS) ) ) 

(SETQ READ-PAOOLE-ENB (OR (AND REG-READ-RQ (FIELD REG-ADDR 8)) 

(AND lO-READ-ACTIVE-CYCLE READ-PAODLE-ENS) ) ) 

;; end of definition 

SCRC:<LMI0B>LBMI0V.PAL:6 

nN;-«- rioderLISPj PackegetUSER; Baee:18 -«- 

?PAL For selecting •eaorg-aapped registere for writing (in drauings LBniO) 

(OEFPAL LBni03 PAL16R8 

(IPIN 2 LB-AODR-IS) 
(IPIN 3 LB-ADOR-17) 
(IPIN 4 LB-ADDR-3) 
(IPIN 5 LB-ADDR-2) 
(IPIN 6 LB-AODR-1) 
(IPIN 7 LB-ADOR-8) 
; ; 8 spare 

(IPIN 9 lO-URITE-RQ) 

(RPIN 19 URITE-DIS<-COnnAND) 
(RPIN 18 URITE-DISK-DIAG) 
(RPIN 17 tWITE-NET-DIAG) 
(RPIN 16 URITE-NET-CNTRL) 
(RPIN 15 URITE-VD-CNTRL) 
(RPIN 14 URITE-AUD-CNTRL) 
(RPIN 12 URITE-PADDLE-ENB) 

(FIELD REG-ADDR LB-ADOR-3 LB-ADDR.2 LB-AOOR-1 LB-AOOR-0) 

(SETQ REG-URITE-RQ (AND (NOT LB-AOOR-IS) (NOT LB-ADDR-17) lO-URITE-RQ)) 

(SETQ URITE-OISJC-COftlAND (AND REG-URITE-RO (FIELD REG-ADDR 0))) 

(SETQ URITE-OIS»C-OIAG (AND REG-URITE-RQ (FIELD REG-ADOR 2))) 

(SETQ URITE-NET-CNTRL (AND REG-URITE-RQ (FIELD REG-ADDR 4))} 

(SETQ URITE-NET-DIAG (AND REG-URITE-RQ (FIELD REG-ADDR 5)}) 

(SETQ URITE-VD-CNTRL (AND REG-URITE-RQ (FIELD REG-ADDR B))) 

(SETQ URITE-PADDLE-ENB (AND REG-URITE-RQ (FIELD REG-ADDR 8.))) 

(SETQ URITE-AUD-CNTRL (AND REG-URITE-RQ (FIELD REG-ADDR 9.))} 

;; end of definition 

SCRC:<LMI0B>LBSEL1,PAL:7 

;-«- Hode:LISP; Pack»ge:USER; Base:10 -«- 

iPAL Fop selecting eeeory-eapped registers for reading (in drauings LBSEL) 
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(DEFPAL LBSELl PAL16R8 
(IPIN 3 LB-ADDR-IS) 
(I PIN 4 LB-ADDR-17) 
(IPI-N 5 LB-ADDR-2) 
(IPIN 6 LB-ADDR-1) 
(IPlN 7 LB-AODR-0) 
(IPIN 8 lO-READ-ACTIVE-CYCLE) 
(IPIN 9 lO-READ-RQ) 

(RPIN 19 READ-DISK-COnriAND L) 
(RPIN 18 READ-DISK-ECC L) 
(RPIN 17 READ-DISK-STATUS L) 
(RPIN IS READ-DISK -RPS L) 
(RPIN 15 READ-NET-STATUS L) 
(RPIN 14 READ-VD-STATUS L) 
(RPIN 13 READ-YD-DIAG L) 
(RPIN 12 READ-PADDLE-ENB L) 

(FIELD REG-ADDR LB-ADDR-2 LB-ADOR-l LB-ADDR-0) 

(5ETQ REG-READ-RQ (AND (NOT LB-AOOR-18) (NOT LB-ADDR-17) lO-READ-RQ)) 

(SETQ READ-OISK-CDnriAND (OR (AND REG-READ-RQ (FIELD REG-ADDR 0)! 

(AND IO-REAO-ACTIVE*CyCL£ READ-DISK-COnnAND)) ) 

(SETO READ-DISK-ECC (OR (AND REG-READ-RD (FIELD REG-ADDR D) 

(AND lO-READ-ACTIVE-CYCLE READ-DISK-ECC))) 

(SETQ REAO-DISK-STATUS (OR (AND REG-READ-RQ (FIELD REG-ADDR 2)) 

(AND lO-READ-ACTIVE-CYCLE REAO-DISK-STATUS))) 

(SETQ READ-DISK -RPS (OR (AND REG-READ-RQ (FIELD REG-ADDR 3)) 

(AND ID-READ-ACTIVE-CYCLE READ-DISK-RPS))) 

(SETQ READ-NET-STATUS (OR (AND REG-READ-RQ (FIELD REG-ADDR 4)) 

(AND lO-READ-ACTIVE-CYCLE READ-NET-STATUS))) 

(SETQ READ-VD-STATUS (OR (AND REG-READ-RQ (FIELD REG-AOOR 5)) 

(AND ID-READ-ACTIVE-CYCLE READ-VD-STATUS))) 

(SETQ READ-VD-DIAG (OR (AND REG-READ-RQ (FIELD REG-ADDR S)) 

(AND lO-REAO-ACTlVE-CYCLE READ-VD-Dfl-ADR) ) ) 

(SETQ READ-PADDLE-ENB (OR (AND REG-READ-RQ (FIELD REG-ADDR 7)) 

(AND lO-READ-ACTIVE-CYCLE READ-PADDLE-ENB))) 

;; end of def ini tion 
SCRC:<LMIOB>LBSEL2.PAL:3 

5-*- node:LISP: Package: USER; BaseilS -«- 

;PAL For eelecting neeory-eapped regietere for reading (in drawings LBSEL) 

(DEFPAL LBSEL2 PALieR8 

(IPIN 3 LB-ADDR-18) 
(IPIN 4 LB-ADDR-17) 
(IPIN 5 LB-ADDR-2) 
(IPIN 6 LB-AODR-1) 
(IPIN 7 LB-ADDR-8) 
;; 8 spare 

(IPIN 9 lO-URITE-RQ) 

(RPIN 19 URITE-DISK-COnnAND L) 

(RPIN 18 URITE-DISK-DIAG L) 

(RPIN 17 URITE-NET-DIAG L) 
;; IG SPARE 

(RPIN 15 URITE-NET-CNTRL L) 

(RPIN 14 URITE-VD-CNTRL L) 
;: 13 SPARE 

(RPIN 12 URITE-PAODLE-ENB L) 

(FIELD REG-AOOR LB-AODR-2 LB-AODR-1 LB-ADOR-0) 

(SETQ REG-URITE-RQ (AND (NOT LB-ADDR-18) (NOT LB-AOOR-17) lO-URITE-RQ)) 
(SETQ URITE-OISK-COnriAND iAND REG-URITE-RQ (FIELD REG-ADDR 8))) 
(SETQ URITE-DISK-DIAG (AND REG-URITE-RQ (FIELD REG-ADDR 1))) 
(SETQ URITE-NET-DIAG (AND REG-URITE-RQ (FIELD REG-ADDR 2))) 
;; 3 is spare 

(SETQ URITE-NET-CNTRL (AND REG-URITE-RQ (FIELD REG-ADDR 4))) 
(SETQ URITE-VD-CNTRL (AND REG-URITE-RQ (FIELD REG-ADDR 5))) 
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;; £ it spars 

(SETQ URITE-PAODLE-ENB (AND REG-URITE-RQ (FIELD REG-AOOR 7))) 
;; end of definition 

SCRC : <LMI0B>LBSEL3 . PAL ; 8 

;-ft- node:LISP; Package :Lr5ER; Basetie -»- 

J PAL Fop ee lee ting eicpodevice write pegieters (or pseudo regi steps) 
;(in drawings LBSEL) k w 

{Each device on the board takes up a eicrodevice write address space of 
» ^^j;?S*-?ii* (eight reaisters). The task must be able to do a DMA write, 
;a DlSniSS write, a TAS< END write or any combination of the three in 
:the same write. 

(DEFPAL LBSEL3 PAL1BL8 
(IPIN 3 LB-URITE) 
(IPIN 4 LB-DEV-A) 
(IPIN 5 LB-DEV-3) 
(IPIN 6 LB.DEV.2) 
(IPIN 7 LB-DEV-l) 
(IPIN 8 LB-DEV.8) 
(IPIN 9 LB-DEV-URITE) 
(IPIN 11 DEVICE-nATCH L) 

(OPIN 18 DIS<-DnA-RQ-CYCLE) 
(OPIN 17 DISK-DISniSS) 
(OPIN IS DISK-END) 
(OPIN 15 DIS<-TAS<-ACK) 
(OPIN 14 NET-OnA-RQ-CVaE) 
(OPIN 13 NET-OISniSS) 
(OPIN 13 NET-END) 
(OPIN 12 OriA-TO-rEn-RQ-CYCLE) 

(FIELD DEVICE-ADDRESS LB-DEV-4 LB-DEV-3) 

; upper two bits specify which device you're talking to 
; 68 — disk 
: Bl — net 
5 11 — TV 

(SETQ DISK-SELECT (AND (FIELD DEVICE-ADDRESS 9) DEVICE-HATCH)) 
(SETQ NET-SELECT (AND (FIELD DEVICE-ADDRESS 1) DEVICE-flATCH)) 
; lower three bits specify the function 
(FIELD OP LB-DEV-2 LB-DEV-l LB-DEV-8) 

DISK FUNCTIONS 

wpite disk buffep directly (rev 2 and later) 

1 dma cycie (start dma cycle without dismissing) 

2 diseiss, task acknowledge (just clear wakeup) 

3 dismiss ft dma cycle 

4 dismiss (only) 

5 ki I i disk task 

6 dismiss, task acknowledge, eet end flag 

7 dma cycle & set end flag ft dismiss 

(SETQ DISK-OnA-RQ-CYCLE (AND DISK-SELECT LB-DEV-URITE (FIELD OP (1 3 7)))) 
(SETQ DISK-DISniSS (AND DISK-SELECT LB-DEV-URITE (FIELD OP (234567)))) 
(SETQ DISK-END (AND DISK-SELECT LB-DEV-URITE (FIELD OP (6 7)))) 
(SETQ DISK-TASK-ACK (AND DISK-SELECT LB-DEV-URITE (FIELD OP (2 6)))) 
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NET OPERATIONS 
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(SETQ NET-OriA-RQ-CYCLE (AND NET-SELECT LB-DEV-URITE LB-DEV-H)) 
(SETQ NET-DISMISS (AND NET-SELECT LB-DEV-URITE LB-DEV-D) 
(SETQ NET-END (AND NET-SELECT LB-DEV-URITE LB-DEV-2)) 

/ii-TA^nMA'Trt^^SJ-^SS !!«"y^"or" terms, use the feedback versions 

(SETQ DnA-TO-n£n-RQ-CYCCE (AND LB-URITE (OR DISK-DMA-RQ-CYCLE NET-DHA-RQ-CYCLE) ) ) 

; ; ; end of def ini t ion 



4,887,235 
1139 1140 

SCRC:<LMI0B>LBSEL4.PAL:4 

;-«- riode:LISP; Package:USER; Ba8c:18 -«- 

;PAL For aeiectinq Ricrodevice urite regietaps Cop pteudo pegiateps) 
; (in dpauings LBShL) 

;Each device on the board takes up a micpodevice wpite addpess apace of 
; three bits (eight peqistepe). The task must be able to do a DtlA wpite, 
;a OISHISS upite, a TASK END wptte op any combination of the three in 
; the same wpi te. 

(DEFPAL LBSEL4 PAL16L8 

(IPIN 1 SLOT-ADDR-MATCH L) 

(IPIN 2 LB-DEV-4) 

(IPIN 3 LB-DEV-3) 

(IPIN 4 LB-DEV-2) 

(IPIN 5 LB-DEV-1) 

(IPIN 6 LB-DEV-0) 

(IPIN 7 LBU5- ID-REQUEST L) 

(IPIN 8 LB-DEV-READ) 

(IPIN 9 LB-DEV-URITE) 

(IPIN 11 DEVICE-HATCH L) 

(DPIN 18 REAO-DIS<-BUF L) 
;(DPIN 17 READ-NET-BUF L) 

(OPiN 17 icill-disk:-tas< L) 

(DPIN 16 READ-NET-CRC L) 
(OPIN 15 URITE-NET-BUF L) 
(OPIN 14 VD-DISniSS L) 
(OPIN 13 ID-READ-CYCLE) 
(OPIN 19 DEV-URITE-CYCLE) 
(OPIN 12 DEV-REAO-CYaE) 

(FIELD DEVICE-ADDRESS LB-DEV-4 LS-DEV-S) 

(FIELD DEVICE-OP-CODE LB-DEV-2 LB-DEV-1 LB-OEV-B) 

uppep two bits specify which device youVe talking to 
88— d i sk 

01 net 

10 net buffep 

11 TV 

DISK OPERATIONS 

upite disk buffep dipcctly (pev 2 and latep) 

1 dffia cycle (stapt dma cycle without dismissing) 

2 , dismiss, task acknowledge (just cieap wakeupJ 

3 dismiss & dma cycle 

4 dismiss (only) 

5 kill disk task 



6 
7 



dismiss* task acknowledge, set end flag 
dma cycie & set end flag 6 dt amiss 



lag 

(5ETQ DISniSS-RQ (AND LB-DEV-1 LB-DEV-WRITE)) 

(SETQ VD-SELECT (AND DEVICE-HATCH (FIELD DEVICE-ADDRESS 3))) 

(SETQ DEV-URITE-CYCLE (AND DEVICE-MATCH LB-DEV-URITE)) 

(SETQ DEV-READ-CYCLE (AND DEVICE-flATCH LB-DEV-READ)) 

(SETQ READ-DISK-BUF (AND (FIELD DEVICE-ADORESS 0) 

(FIELD DEVICE-DP-CODE 0) 
DEV-READ-CYCLE)) 

(SETQ ICILL-DIS*C-TAS< (AND (FIELD DEVICE-ADDRESS 0) 

(FIELD DEVICE-DP-CODE 5) 
OEV-URITE-CYCLEU 

(SETQ READ-NET-BUF (AND (FIELD DEVICE-ADDRESS 1) 

(FIELD DEVICE-OP-CODE 0) 
DEV-READ-CYCLE H 

(SETQ READ-NET-CRC (AND (FIELD DEVICE-ADDRESS 1) 

(FIELD DEVICE-OP -CODE 2) 
DEV-READ-CYCLE)) 

(SETQ URITE-NET-BUF (AND (FIELD DEVICE-ADDRESS 2) 

(FIELD DEVICE-DP-CODE 0) 
DEV-URITE-CYCLE)) 

(SETQ VD-DISniSS (AND VD-SELECT DISniSS-RQl) 

(SETQ ID-READ-CYCLE (AND LBUS- ID-REQUEST SLDT-ADDR-riATCH) ) 

:; ; end of def inr tron 
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SCRC : <LMIOB>LBWAIT . PAL ; 3 

;-«- nod«:LISP5 PacKagetUSER; BAS£:18 -«- 

jPAL for deciding uhan to hang the bus. PAL appears on dug. PtEIICTL.EWG. 

(DEFPAL LBUAIT PAL16n4 

t CI PIN 1 LB-CLOCIC L) NOT LB STATE CLOCK i 
; (IPIN n GNO) output enable. 

(IPIN 2 CACHE-HIT L) 
(IPIN 3 CACHE-DIRTY L) 
(IPIN 4 LB-TV-REQ L) 
(IPIN 5 REF-REQ L) 
(IPIN 6 CACHE-ACTIVE) 
(IPIN 7 On-ACTIVE-CYCLE) 
(IPIN 8 PANIC) 
(IPIN 9 LIT-REQ L) 
(IPIN 12 LB-REFRESH L) 
(IPIN 13 LB-ADDR-e8) 
(IPIN 18 FULLNESS) 

(RPIN 17 ASSERT-LB-UAIT L) 

(OPIN 19 CLEAR-LB-UAIT L) I INTERNAL USE 

(SETQ ASSERT.LB4MIT (OR (AND LB-TV-REQ DH- ACTIVE-CYCLE) 

(AND LB-TV-REQ LIT-REQ) 
(AND LB-TV-REQ PANIC) 

(AND LB-TV-REQ (NOT CACHE-HIT) CACHE-DIRTV) 
(AND ASSERT-LB-UAIT (NOT CLEAR-LB-UAIT)))) 

(SETQ CLEAR-LB-UAIT (AND ASSERT-LB-UAIT (NOT TV-OTI-ACTIVE))) 

uEfC OF DEFINITION 

SCRC :<LMIOB>LITCtL. PAL; 1 

;-»- node:LISP; PackagetUSER; BA5E:10 -«- 

;PAL for controlling the Line Index Table. See dwg. TVADR9. 

(DEFPAL LITCTL PALIBRA 

: (IPIN 1 LB-STATE-aOCK L) 

I (IPIN 11 GND) output enabte. 

(IPIN 2 LIT-RESET L) 
(IPIN 3 REFRESH-On-ACTIVE L) 
(IPIN 4 TV-Dn-ACTIVE L) 
(IPIN 5 CPU-On-ACTIVE L) 
(IPIN e REFRESH-DATA-CYCLE L) 
(IPIN 7 TV-DATA-CYCLE L) 
(IPIN 8 CPU-DATA-CYCLE L) 
(IPIN 9 LIT-REQ L) , 
(IPIN 12 DtO-lB) 

(RPIN IS OOO-CHUNK-COUNT L) 
(RPIN 15 LIT-DATA-CYCLE L) 
(RPIN 14 LIT-On-ACTIVE L) 

(OPIN 19 Dn-DATA-CYCLE) INTERNAL USE 

;000 CHUNK COUNT means there are fkn odd number of 64-pixe! chunks that are to be read froe 
?the TV eee during this scan line. DHD 16 is the LSB of the chunk count. This info 
;eust be kept around so that the FIFO etuffer knous how to ignore the last chunk and to 
;not put It in the FIFO, 

(SETQ OOO-CHUNK-COUNT (OR (AND DflD-lS LI T-OH- ACTIVE) tsets the bit 

(AND OOO-CHUNK-COUNT (NOT LIT-DM-ACTIVE) ))) {holds it on 

jLIT DATA CYCLE happens one LBUS STATE after the LIT ACTIVE cycle. 

(SETQ LIT-DATA CYCLE (AND LIT-Dtt-ACTIVE (NOT LIT-DATA-CYCLE))) 

;LIT OH CYCLE is the highest priority thing that can happen to the TV eee. At the end of 
$a scan line, LIT REQ is asserted. This PAL gets the TV nen so it can go into the LIT 
;and find the starting address for the next scan line eegment. 

(SETQ LIT-On-ACTIVE (AND LIT-REQ (NOT DTI-ACTIVE-CYCLE))) 

(SETQ On-OATA-CYCLE (OR LIT-DATA-CVaE TV-DATA-CYCLE CPU-DATA-CYCLE REFRESH-DATA-CYCLE)) 

:?END OF DEFINITION 
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SCRC:<LMrOB>LW<I01.PAL;3 

;-»- node:LISP: Packagc:USER; BasetlS -«- 

;PAL Fop ielecting weBory-aapped registers for reading (in drauings LBHIO) 

(DEFPAL LBfllOl PAL1BR8 
(IPIN 2 LB-ADDR-IS) 
(IPIN 3 LB-ADOR-17) 
(IPIN 4 LB-ADDR-3) 
(IPIN 5 LB-ADDR-2} 
(IPIN B LB-ADDR-1) 
(IPIN 7 LB-ADOR-8) 
(IPIN 8 lO-READ-ACTIVE-CVCLE) 
(IPIN 9 lO-REAO-RQ) 

(RPIN 19 READ-DISK-COnriAND L) 
(RPIN 18 READ-OISIC-ECC L) 
(RPIN 17 READ-DISIC-STATUS L) 
(RPIN 16 READ-DISIC-RPS L) 
(RPIN 15 READ-NET-STATUS L) 
(RPIN 14 READ-VD-STATUS L) 
(RPIN 13 READ-VD-DIAG L) 
<RPIN 12 READ-PADOLE-ENB L) 

(FIELD REG-AODR LB-ADDR-S LB-A0DR.2 LB-AODR-l LB-ADDR-e) 

(SETQ REG-REAO-RQ (AND (NOT LB-ADDR-18) (NOT LB-ADDR-H) lO-READ-RQ}) 

(SETQ REAO-DISK-COrmAND (OR (AND REG-READ-RQ (FIELD REG-ADDR 8)) 

(AND lO-READ-ACTIVE-CYCLE REAO-OISK-COmAND) ) ) 

(SETQ READ-DISK -ECC (OR (AND REG-REAO-RQ (FIELD REG-AOOR D) 

(AND lO-fiEAD-ACTIVE-CYCLE READ-DISK-ECC))> 

(SETQ READ-DISK-STATUS (OR (AND REG-REAO-RQ (FIELD REG-AODR 2)) 

(AND lO-READ-ACTIVE-CYCLE READ-DISK-STATUS))) 

(SETQ READ-DISK-RPS (OR (AND REG-READ-RQ (FIELD REG-AODR 3)) 

(AND lO-REAO-ACTIVE-CYCLE READ-DISK-RPS))) 

(SETQ READ-NET-STATUS (OR (AND REG-READ-RQ (FIELD REG-AODR 4)) 

(AND lO-REAO-ACTIVE-CYCLE READ-NET-STATUS))) 

(SETQ READ-VD-STATUS (OR (AND REG-READ-RQ (FIELD REG-ADDR B)) 

(AND lO-REAO-ACTIVE-CYCLE REAO-VO-STATUS))) 

(SETQ READ-VD-DIAG (OR (AND REG-REAO-RQ (FIELD REG-ADDR 7)) 

(AND lO-READ-ACTIVE-CYCLE READ-VD-DIAG))) 

(SETQ READ-PADDLE-ENB (OR (AND REG-READ-RQ (FIELD REG-ADDR 10)) 

(AND lO-REAO-ACTIVE-CYCLE READ-PADOLE-ENB))) 

;; end of definition 
SCRC : <LMIOB>MEMCTL . PAL ; 5 
:-». node:LISP; Package:USER; BASEilB -«- 

jdS.^nEncTL.mG!'"^ *^* •***" °^ ^^ ^^^^^^ ^^^ *^* ^^ ""^^y- ^*' •PP"^' °" 

(DEFPAL tETlCTL PAL1SL8 

(IPIN 1 LB-URITE) 
(IPIN 2 CACHE-HIT L) 
(IPIN 3 CACHE-DIRTY L) 
(IPIN 4 LB-TV-REQ L) 
(IPIN 5 REF-REQ L) 
(IPIN B CACHE-ACTIVE) 
(IPIN 7 Dn-ACTIVE-CYCLE) 
(IPIN 8 PANIC) 
(IPIN 9 LIT-REQ L) 
(IPIN 11 LB-REFRESH L) 
(IPIN 13 LB-ADDR-00) 
(IPIN 14 CLEAR-LB-UAIT L) 
(IPIN 15 FULLNESS) 

(OPIN 17 CPU-ACTIVE-ENAB L) 
(OPIN 18 REFRESH-ENAB L) 
(OPIN 19 REF-REQ-ENAB L) 
(OPIN 12 TV-ACTIVE-ENAB L) 

(SETQ TV-ACTIVE-ENAB (OR (AND (NOT LIT-R|Q) (NOT CPU-REQ) (NOT REF-OH-EN) (NOT REF-REQ) 

(NOT FULLNESS) (NOT Dn-ACTIVE-CYCLE) (NOT CA(:hE-ACTIVE) ) 
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tlht fifo i« in panic aode. Give it the cyclft« 

(AND (NOT LIT-REQ) (NOT DH-ACTIVE-CYaE) PANIC))) 

{Cache atss. Cache i« enpty. 

(SETQ CPU-ACT I YE-ENAB (OR (AND (NOT LIT-REQ) (NOT PANIC) (NOT REF-REQ) (NOT DM -ACTIVE -CYCLE) 

(NOT CACHE-HIT) (NOT CACHE-DIRTY) LB-TV-REQ) 

?Cache aiee. Cache ie full. Must assert urite during this cycle, assert LBUS WAIT, flush 
; cache, then request another cycle for the CPU. 

(AND (NOT LIT-REQ) (NOT PANIC) (NOT REF-REQ) (NOT DTI-ACTIVE-CYCLE) 
(NOT CACHE-HIT) CACHE-DIRTY LB-TV-REQ) "" mumtc utulc; 

jCache is dirty with data in the least significant word. CPU wants to read this data. Data 
:is not yet m the TV eewory. Two birds are killed with one cycle. To the TV nem it 
; ooks tike a write cycle and the data in the cache is stored In TV eem. To the CPU it 
; looks tike a read. The data on DnO<31:08> bus going to the TV eea is clocked into the 
:CPU read reg. 

(AND (NOT LIT-REQ) (NOT PANIC) (NOT REP-REQ) (NOT Dtt-ACTIVE-CYCLE) 

(NOT LB-WRITE) CACHE-HIT CACHE-D I RTY LB-TV-REQ ^'''^^ ^''-^^^ 

(NOT CPU-ADOR-ea) ) 

;Cache is hit. CPU wants to write data into the high haH which ie not dirty. Since 
:thc next operation will eost likely be at the current address plus one, which would 
t cause a aiss, write it thru now. 

(AND (NOT LIT-REQ) (NOT PANIC) (NOT REF-REQ) (NOT Dfl-ACTIVE-CYCLE) 
LB-TV-REQ CACHE-HIT (NOT CACHE-DIRTY) LB-ADDR-88 LB-URITE) 

;Read cycle, cache hit but empty. CPU wants the low half of cache but it ie not dirty. 
:nu8t go get fresh data. * 

(AND (NOT LfT-REQ) (NOT PANIC) (NOT REF-REQ) (NOT Dfl-ACTIVE-CYCLE) 
(NOT LB-URlTE) CACHE-HIT LB-TV-REQ (NOT CACHE-DIRTY)) 

;LBUS wants to refresh the RAH's and we are not panicking or LITing. Do it. 

(SETQ REFRESH-On-ENAB (OR (AND (NOT LIT-REQ) (NOT PANIC) LB-REFRESH (NOT DTI-ACTIVE-CYCLE)) 

;A request for RAM refresh has been logged but not honored yet. It is OK now. 

(AND (NOT LIT-REQ) (NOT PANIC) REF-REQ (NOT Dtt-ACTIVE-CYCLE) )) ) 

;LBUS wants to refresh the RAMs but something acre iaportant is happening. Log the request 
;Tor a acre fun tine. 

(SETQ REF-REQ (OR (AND LB-REFRESH LIT-REQ) 
(AND LB-REFRESH PANIC) 
(AND LB-REFRESH DH-ACTIVE-CYCLE) 
(AND REF-REQ (NOT REFRESH-DM-ENAB) ) )) 

::END OF DEFINITION 
SCRC:<LMI0B>IICRC1.PAL:7 

:-«. ttode:LISP; Package:USER; Base:10 -«- 

?One of the PALS for doing CRC error checking for the Ethernet. 

(DEFPAL NCRCl PAL1SR8 ;PAL1SR8A 

(IPIN 5 CRC-FEEDBACK Li ,r«i.iDnon 

(IPIN e CRC-CONTROL L) 
(IPIN 7 CRC-15) 
(IPIN 8 CRC-25) 
(IPIN 9 NET-COLLISION) 

(RPIN 12 CRC-8) 
(RPIN 13 CRC-1) 
(RPIN 14 CRC-2) 
(RPIN 15 CRC-3) 
(RPIN 16 CRC-4) 
(RPIN 17 CRC-5) 
(RPIN 18 CRC-IS) 
(RPIN 19 CRC-2S) 

;The CRC logic is basic! Ig a 32 bit shift register with XOR's at critical 
;places in the shift bit streaa. 

;If tt^ CRC-CONTROL input is true certain bits get the xor of the previous 
jbit in the streae and CRC-FEEDBACK. prov.oua 

(SETQ CRC-SHIFT (NOT CRC-CONTROL)) 

(SETQ CRC-INV NET-COLLISION) ; invert the crc when colliding 

(SETQ CRC-0 
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(COND (CRC-CONTROL CRC-FEED8ACO 
(CRC-INV NIL) 

(SETQ CRC-1 ^"^^-^^^^ ^^^^ ^Shift In Vn 

.(COND (CRC-CONTROL (XOR CRC-FEEDBACK CRC-B)) 
(CRC-INV (NOT CBC-e)\ 
(CRC-SHIFT CRC-2i)) 

CSETQ CRC-2 

CCOND (CRC-CONTROL (XOR CRC-FEEIDBADC CRC-D) 
(CRC-INV (NOT CRC-1) ) 
(CRC-SHIFT CRC-1))} 

(SETQ CRC-3 (COND (CRC-INV (NOT CRC.2)) :Siitp)e shift 

((NOT CRC-INV) CRC-2))) ^ 

(SETQ CRC.4 

(COrJO (CRC-CONTROL (XOR CRC-FEEDBAC< CRC-3)) 
(CRC-INV (NOT CRC-3}} 
(CRC-SHIFT CRC-3))) 

(SETQ CRC-5 

(COND (CRC-CONTROL (XOR CRC-FEEDBACK CRC-4}) 
(CRC-INV (NOT CRC-4)} 
(CRC-SHIFT CRC-4})) 

(SETQ CRC-16 

(CONO (CRC-CONTROL (XOR CRC-FEEDBACIC CRC-IS)) 
(CRC-INV (NOT CRC-25)) 
(CRC-SHIFT CRC-15}}) 

(SETQ CRC-2S 

(CRC-SHIFT CRC-25))} 
:; end of definition 

SCRC:<LMI0B>NCRC2.PAL;4 

;-»- node: LISP; Package: USER; Ba«e:10 -«- 

;One of the PALS for doing CRC error checking for the Ethernet. 

(DEFPAL NCRC2 PAL1BR8 :PAL16R8A 

(IPIN 5 CRC-FEEDBACK L) •rMuxono« 

(IPIN 6 CRC-CONTROL L) 
(IPIN 7 CRC-S) 
(IPIN 8 CRC-21) 
(IPIN 3 NET-COLLISION) 

(RPIN 12 CRC-7) 
(RPTN 13 CRC-8) 
(RPIN 14 CRC-9) 
(RPIN 15 CRC-10) 
(RPIN 16 CRC-11) 
(RPIN 17 CRC-12} 
(RPIN 18 CRC-22) 
(RPIN 19 CRC-23) 

;Thc CRC logic is baaiclly a 32 bit shift register with XOR's at critical 
;places in the shift bit stream. 

; If the CRC-CONTRX Input is true certain bits get the xor of the previous 
:bit in the stream and CRC-FEEDBACK. 

(SETQ CRC-SHIFT (NOT CRC-CONTROL)) 

(SETQ CRC-INV NET-CXLISION) j invert the crc when colliding 

(SETQ CRC-7 

(COND (CRC-CONTROL (XOR CRC-FEEDBACK CRC-S) ) 
(CRC-INV (NOT CRC -6)} 
(CRC-SHIFT CRC-6}}} 

(SETQ CRC-8 

(COND (CRC-CONTROL (XOR CRC-FEEDBACK CRC-7}) 
(CRC-INV (NOT CRC-7}) 
(CRC-SHIFT CRC-7}}} 

(SETQ CRC-9 (COND (CRC-INV (NOT CRC-8)} tSiitpie shift 

((NOT CRC-INV) CRC-8}}) .^ -ip.e hhitx 

(SETQ CRC-10 

(CONO (CRC-CONTROL (XOR CRC-FEEDBACK CRC-9)} 
(CRC-INV (NOT CRC-9)) 
(CRC-SHIFT CRC-9})} 
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(SETQ CRC-11 

(COND (CRC-CONTROL (XOR CRC-FEEDBAC< CRC-18)) 
(CRC-INV (NOT CRC-10)) 
(CRC-SHIFT CRC-ie))) 

(SETQ'CRC-12 

(COND (CRC-CONTROL (XOR CRC-FEEDBACIC CRC-ID) 
(CRC-INV (NOT CRC-ID) 
(CRC-SHIFT CRC-U)}} 

(SETQ CRC-22 

(COND (CRC-CONTROL (XOR CRC-FEEDBACK CRC-21)) 
(CRC-INV (NOT CRC-21)) 
(CRC-SHIFT CRC-21))) 

(SETQ CRC-23 

(COND (CRC-CONTROL (XOR CRC-FEEDBADC CRC-22)) 
(CRC-INV (NOT CRC-22)) 
(CRC-SHIFT CRC-22))) 

:; end of definition 

SCRC:<LMI0B>NCRC3*PAL;3 

t-«- node:LISP; PackagetUSER; Batarld -«- 

:One of the PALS for doing CRC trpop checking for the Ethernet. 

(DEFPAL NCRC3 PALIBLS 
(IPIN 18 CRC-0) 
(IPIN 17 CRC-1) 
(IPIN IS CRC-2) 
(IPIN 15 CRC-3) 
(IPIN lA CRC-4) 
(IPIN 13 CRC-S) 
(IPIN 1 CRC-6) 
(IPIN 2 CRC-7) 
(IPIN 3 CRC-8) 
(IPIN 4 CRC-9) 
(IPIN 5 CRC-10) 
(IPIN G CRC-U) 
(IPIN 7 CRC-12) 
(IPIN 8 CRC-13) 
(IPIN 9 CRC-14) 
(IPIN 11 CRC-15) 

(FIELD CRC-A CRC-15 CRC-14 CRC-13 CRC-12 CRC-11 CRC-18 CRC-9 CRC-8 CRC-7 CRC-6 
CRC-5 CRC-4 CRC-3 CRC-2 CRC-1 CRC-^) 

(OP IN 19 CRC-OK-A L) 

(SETQ CRC-OK-A (FIELD CRC-A #ol56573)) 

;: end of def ini tion 

SCRC:<LMI0B>NCRC4.PAL:4 

;-»- riodezLISP; Package: USER; BasetlB -*- 

;One of the PALS for doing CRC error checking for the Ethernet, 



(DEFPAL NCRC4 


PAL16L8 


(IPIN 


18 CRC 


:-16) 


(IPIN 


17 CRC 


:-17) 


(IPIN 


16 CRC 


:-i8) 


(IPIN 


15 CRC 


:-i9) 


(IPIN 


14 CRC 


;-2a) 


(IPIN 


13 CRC 


:-2i) 


(IPIN 


1 CRC- 


■22) 


(IPIN 2 CRC 


•23) 


(IPIN 


3 CRC- 


•24) 


(IPIN 4 CRC- 


•25) 


(IPIN 


5 CRC- 


-25) 


(IPIN 6 CRC- 


27) 


(IPIN 


7 CRC- 


.28) 


( PIN 


8 CRC- 


29) 


( PIN 


9 CRC- 


.30) 



(IPIN 11 CRC-31) 

(FIELD CRC-B CRC-31 CRC-30 CRC-29 CRC-28 CRC.27 CRC.26 CRC-2S CRC.24 CRC.23 CRC-22 
CRC-21 CRC-20 CRC-19 CRC-18 CRC-17 CRC-16) 

(OPIN 19 CRC-OIC-B L) 

(SETQ CRC-OK-B (FIELD CRC-B <rol434a4)) 

5! end of def ini tion 
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SCRC : <LMI0B>NCRC5 . PAL : 10 

;-*- ttocle:LISP; PackagetUSER; Ba8e:ld -»- 

;One of the PALS for doing CRC error checking for the Ethernet. 

(DEFPAL NCRC5 PAL1BL8 -PALISLSA actual lu 

(IPIN 16 NET-P<T-RCVD) ,rw-ibLBA actually 

(IPIN IB CRC-OK-B L) 
ilPlH 14 CRC-0<.A L) 

PIN 13 NET-CRC-ERROR) 
(IPIN 1 CRC-31) 
(IPIN 2 NET-RCV.QATA) 
(IPIN 3 NET-RCV-ENABLE) 
(IPIN 4 NET-PKT-BEING-RCVD L) 
(IPIN 5 NET-P<T-BEING-XnTD L) 
(IPIN S NET-RESET L) 
(IPIN 7 NET-XnT-DATA) 
(IPIN 8 NET-XnT"STATE-0) 
(IPIN 9 NET-XHT-STATE-l) 
(IPIN 11 NET-UORO-CK L) 
(FIELD XMT-STATE NET-XTIT-STATE-l NET-XHT-STATE-B) 

(OPIN 18 SET-CRC-ERROR L) 
(OPIN 17 NET-IDLE L) 

(OPIN 19 CRC-FEEDBACX L) 
(OPIN 12 CRC-CONTROL L) 

(SETQ NET-XMT-ENABLE (NOT NET-RCV-ENABLE)) 

(SETQ SET-CRC-ERROR 

(AND (NOT NET-RESET) 
(OR NET-CRC-ERROR 

'^fiE?Iu(5K^-°'-'^-^-'*^ 
NET"P<T-RCVO)}}) 

(SETQ NET-IDLE (AND (NOT NET-PiCT-BEING-RCVO) (NOT NET-PKT-BEING-XriTD)}) 
(SETQ CRC-FEEDBACIC 

(XOR (OR (AND NET-XnT-ENABLE NET-XTIT-DATA) 

. ' (AND NET-RCV-ENABLE NET-RCY-DATA) ) 

£^0^—31 ) J 

(SETQ CRC-CONTROL 

^^ {^tiS ti^I-S£^^^*BLE NET-PKT-BEING-RCVD) 

X X end of def ini t ion 

SCRC:<LMI0B>NRCV.PAL;26 

;Two ones in a row Mean the packet starts. Uhen data valid goes auag ue know 
;the packet has ended (then we go back to packet-wait) 

(SETQ NET-PICT-BEING-RCVD 

(AND (OR NET-PKT-BEING-RCVD 

(AND NET-PREAHBLE-OfC 
AET-DATA-VALID 

iiT:irJ'^nrTk.^?"^^ «^°"* '00*^ ^or- 8-bit tiaes 

NO-ERROR 
NET-DATA-VALIO)) 

(SETQ CLEAR-NET-PICT-RCVD (AND NET-PKT-RCVD (OR NET-RESET NET-BUF-OE) ) ) 
:; end of definition 

SCRC : <LMIOB>NRCV . PAL ; 26 

;-»- HodetLISP; Package:USER; BanetlB -*- 

-HSXeSmed^ih^^NFfRrvVP^^-*^^ acraprng off the preamble, 

iLl I? ■"umed that NET RCV CLK is always running, aithouoh it aracj 
;be of non-unifor« period when phase locking to ?he incoaTng signai . 

;To get the receiver started, set NET-RCV-ENABLE and then NET-RESET 

(DEFPAL NRCV PALIBRS .p*, ,epcA 

(IPIN 2 NET-PICT-RCVD) ;PAL16R6A 

(IPIN 3 NET-DATA-VALIO-DLYD) 
(IPIN 4 NET-RESET L) 
(IPIN 5 NET-BUF-OE L) 
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(IPIN 6 NET-RCV-ENABLE) 
(IPIN 7 NET-COLLISION) 
(IPIN 8 NET-DATA-VALID) 
(IPIN 9 NET-RCV-OATA) 
t (IPIN 12 NET-PKT-BE I NG- IGNORED) :Not used 

(RPi'n 13 NET-PREAHBLE-ERROR) 
(RPIN 14 hET-PKT-BEING-RCVO L) 

tTh«8e »ignal8 apen*t ptally used. Thcg are just names for internal 
: states of the FSn. They are read back to the processor for debugaing. 

(RPIN 15 NET-START L) ^^ " 

(RPIN IG NET-UAIT-FOR-P»CT U 

(RPIN 17 NET-PREAMBLE-ZERO L) 

(RPIN 18 NET-PREAflBLE-ONE L> 

COPIN 19 CLEAR-NET-PKT-RCVO L) 

{This FSn ts very staple. It has 7 states and each state is represented 
sby one bit of the register. No tuo bits should ever be on at the same 
;ti»e« This should saKe debugging it easy. 

;; These are gross errore 

(SETQ RCV-QOIT (OR NET^OLLISION 

NET-PREAnBLE-ERROR 
(NOT NET-RCV-ENABLE) ) ) 

(SETQ NO-ERROR (NOT (OR NET-RESET 

NET-PKT-RCYO 
RCV-QUIT)}) 

;; Start if reacting and the Minimal condition that receiving is enabled, 
;; otherwise only start if done and not losing. 

(SETQ NET-START 

(AND NET-RCV-ENABLE 

(OR NET-RESET • 
NET-PKT-RCVD 
(AND (NOT RCV-QUIT) jdon't start if losing 

(NOT NET-PtCT-RCVD) ;or done and not finished 
(NOT NET-WAIT-FOfl-PJCT) :or in the wait etate 
NET-START) J ) ) ;hold until transition to w-f-p 

(SETQ NET-UA1T-F0R-P»CT 

(AND NO-ERROR jstart looking for packets if there ^rm no errors 

(OR (AND NET-START jand if ue are in the START etate or 

_ (NOT NET-OATA-VALID)) jand there is no data currently (may be aborting) 
NET-UAIT-FOR-P<T) ;hold if already waiting * « w 
(NOT (OR NET-PREAflBLE-ZERO NET-PREAnBLE-0NE>7>) ; until preamble 

(SETQ NET-PREAnSLE-ZERO 
(AND NO-ERROR 

(OR NET-UAIT-FOR-PKT 
NET-PREAHBLE-ONE) 
NET-DATA- VALID 
(NOT NET-RCV-DATA) 
(NOT NET.Pk;T-BEING-RCVD))) 

(SETQ NET-PREAHBLE-ONE 
(AND NO-ERROR 

(OR NET-UAIT-FOR-PKT 

NET-PREAflBLE-ZERO) 
NET-DATA-VALID 
NET-RCV-DATA 
(NOT NET-PKT-BEING-RCVD))) 

:Can*t get tuo zero's in a rou during the preamble. If ue lose on a preamble 
J*^£" ye 5lay i" this state till ue get reset. 
(SETQ NET-PREAHBLE-ERROR ^ 

(AND (NOT NET-RESET) 

(NOT NET-P<T-RCVD) 
(OR NET-PREAHBLE-ERROR 
(AND NET-DATA-VALID 

NET-DATA-VALID-DLYD 
(NOT NET-COLLISION) 
NET-PREAnBLE-ZERO 
(NOT NET-RCV-DATA))))) 

SCRC:<LMI0B>NS£R1.PAL;13 

;-«- node:LISP; Package:USER; Base:10 -»- 

;;; BYTE control PAL. Sequence the assembly of bits into octets (bytes). 

(DEFPAL NSERl PAL1BR8 

; (IPIN 1 NET-CLK L) ;CLK input 

(IPIN 2 NET-RESET L) 
(IPIN 3 NET-XriT-ENABLE) 
CLPIN 4 NET-DATA-VALID) 
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(IPIN 5 NET-P<T.BEING-RCVD L) 
(IPIN e NET-PKT-BEING-XriTD L) 
(IPIN 7 NET-XP1T.STATE-8) 
(IPIN 8 NET-XnT-STATE-l) 
(IPIN 9 NET-BYTE-CNT.3 L) 

(RPIN 12 Q-Q-NET-BYTE-END) 
(RPIN 13 Q-NET-BYTE-END) 
(RPIN 14 NET-BYTE-END) 
(RPIN 15 NET-BC-2 L) 
(RPIN 16 NET-BC-1 L) 
(RPIN 17 NET-BC-0 L) 
(RPIN 18 NET-ALIGN-ERROR) 
(RPIN 19 LOAO-NET-SH) 

(FIELD XHT-STATE NET-Xni-STATE-l NET-XriT-STATE-e) 
(FIELD BC NET-BC-2 NET-BC-1 NET^-8) 

(SETQ NET-RCV-ENABLE (NOT NET-XflT-ENABLE) ) 

(SETQ LOAD-NET-SH (AND NET-XTtT-ENABLE 

IQR CAND f^f[^3^^^-f^|-3^^ ^j, ;1 so can load at end of preamble 

(FIELD^Ic^Gn)'^"^^^^ 2)) j2 is transaitting data state 

(SETQ NET-ALIGN-ERROR 

(AND (NOT NET-RESET) 

(OR NET-ALIGN-ERROR ;hold once set 

(AND NET-RCV-ENABLE 

(NOT NET-OATA-VALID) 
NET-PKT-BEING-RCVD 
(NOT (FIELD BC 7)))))) 

(SETQ NET-BC-ENABLE tessentialtu NET IDLE? 

(OR (AND NET-RCV-ENABLE NET-PKT-BEING-RCVO) ^ 
(AND NET-XnT-ENABLE NET-PKT-BEING-XnTD) ) ) 

(SETQ NET-BC-0 

(Af4D (NOT NET-RESET) 

(OR (AND NET-ALIGN-ERROR NET-BC-8) 

(AND (NOT NEI-ALIGN-ERROR) NET-BC-ENABLE 
(NOT N£T-BC-a>}})) 

(SETQ NET-BC-1 

(AND (NOT NET-RESET) 

(OR (AND NET-ALIGN-ERROR NET-BC-1) 

(AND (NOT NET-ALIGN-ERROR) NET-BC-ENABLE 
(XOR NET-BC-1 NET-BC-8))})) 

(SETQ NET-BC-2 

(AND (NOT NET-RESET) 

(OR (AND NET-ALIGN-ERROR NET-BC-2) 

(AND (NOT NET-ALIGN-ERROR) NET-BC-ENABLE 

(XOR NET-BC-2 (AND NET-BC-1 NET-BC-S) ) ) ) ) ) 

(SETQ Q-Q-NET-BYTE-Ef^D 

(AND (NOT NET-RESET) 

(AND (NOT NET-ALIGN-ERROR) NET-BC-ENfABLE 
(FIELD BC 5)))) 

(SETQ Q-NET-BYTE-END (AND (NOT NET-RESET) Q-Q-NET-BYTE-END) ) 

(SETQ NET-BYTE-END (AND (NOT NET-RESET) Q-NET-BYTE-ENO) ) 

; ; end of def ini t ion 



SCRC : <LMI0B>NSER2 . PAL : 19 

;-«- f1ode:LISP; PackagetUSER; Base: 18 -«- 
;Uord Control 

.^°^rPlN^^2l/^^^.^? :PAL16R8A actual ly 

; (IPIN 1 NET-CLK L) -rLk: innut 



;CLIC input 



(IPIN 2 FEP-USING-NET) 
(IPIN 3 NET-XflT-ENABLE) 
(IPIN 4 NET-DATA-VALID) 
(IPIN 5 NET-PKT-BEING-RCVD L) 
(IPIN 6 NET-PKT-BEING-XnTD L) 
(IPIN 7 Q-NET-BYTE-END) 
(IPIN 8 NET-IBC-8) 
(IPIN 9 NET-IBC-1) 

(RPIN 14 NET-BYTE-CNT.3 L) 
(RPIN 15 NET-UORD-END L) 
(RPIN IS NET-BYTE-CNT-l L) 
(RPIN 17 NET-BYTE-CNT-8 L) 
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:i These arc delayed one cycle free the BYTE CNT 

(ftPIN 12 NET-BYTE-3-EN L) 

(RPIN 13 NET-BYTE-2-EN L) 

(RPIN 18 NET-BYTE-l-EN L) 

{RPIN 13 NET-BYTE-e-EN L) 

(FIELD IBC NET-IBC-1 NET-IBC-e) 

(FIELD BYC NET-BYTE-CNT-1 NET-BY TE-CNT.0) 

(SETQ NET-RCV-ENABLE (M3T NET.XnT.ENABLE}> 

(5ETQ 1ET.U0RD-EN0 

(AND Q-NET-BYTE-END 

(OR (AND NET-RCV-ENABLE 

NET-PICT-BEING-RCVD 

(OR (FIELD BYC 3) (NOT NET-DATA-VALID))) 
(AND NET-XHT-ENABLE 

NET-PKT-BEING-XnTD 
(FIELD BYC 3))))) 

(SETQ NET-BYTE-CNT-3 

(COND (Q-NET-BYTE-ENO (FIELD BYC 2)) 

((NOT Q-NET-BYTE-END) ^£T-BYTE-CNT«3)) ) 

(SETQ NET.BYTE-CNT-8 

(COND (NET-RCV-ENABLE 

(AND NET-PKT-BEING-RCVD 

(COND (Q-NET-BYTE-END (NOT NET-BYTE-CNT-8) ) t COUNT 

((NOT Q-NET-BYTE-END) NET-BYTE-CNT-0) ) } ) jHOLD 

(NET-XriT-ENABLE 
(AND NET-PXCT-BElNG-XriTD 

(COND (Q-NEl-BYTE-EMO 

(COND (NET-UORD-END ICT-I9C-0) iLDAD 

ami NET-UORO-E^S) (NOT NET-BYTE-CNT-e) )) ) 
<(NOT a-NET-BYTE-eC) NET-BYTE-CNT-Bi n J ) ) 

(SETQ NET-BYTE-CNT-l 

(COND (NET-RCV-ENABLE 

(AND NET-PKT-BEING-RCVO 

(COND (Q-NET-BYTE-END (XOR NET-BYTE -CNT-1 NET-BYTE-CNT-0) ) 
((NOT Q-NET-BYTE-END) NET-BYTE-CNT-l) ) ) ) jHOLD 
(NET-XnT-ENABLE 
(AND NET-PKT-BEING-XnTD 

(COND (Q-NET-BYTE-ENO 

(COND (NET-UORD-END NET-IBC-1) jLOAD 
((NOT NET-UORD-END) 



(XOR NET-BYTE-CNT-l NET-BYTE-CNT-B) ) ) ) 
((NOT Q-NET-BYTE-END) NET-BYTE-CNT-l)))}) 



(SETQ NET-BYTE-8-EN 

(OR (AND NET-RCV-£N/^BLE (FIELD BYC (0 3))) 

(AND NET-Xm -ENABLE (FIELD BYC 3) (NOT FEP-USING-NET) )) 

(SETQ NET-BYTE-l-EN 

(OR (AND NET-RCV-ENABLE (FIELD BYC (1 3))) 

(AND NET-XnT-ENABLE (FIELD BYC 0) (NOT FEP-USING-NET))) 

(SETQ NET-BYTE-2-EN 

(OR (AND NET-RCV-ENABLE (FIELD BYC (2 3))) 

(AND NET-XriT-ENABLE (FIELD BYC 1) (NOT FEP-USING-NET))) 

(SETQ NET-BYTE-3-EN 

(OR (AND NET-RCV-ENABLE (FIELD BYC 3)) 

(AND NET-XnT-ENABLE (FIELD BYC 2) (NOT FEP-USING-NET))) 

; ; end of def ini tion 



;HOLD 



; COUNT 
jHXD 



J COUNT 



; COUNT 



) 

SCRC : <LMI0B>IISPY1 . PAL ; 4 



t-ft- f1ode:LISP; PackagesUSER; Baee:10 -»- 

;PAL decoding epy bue cycle requests 

(DEFPAL NSPYl PAL16L8 
(IPIN 14 SPY-7) 
(I PIN 11 SPY-AODR-0) 
(IPIN 9 SPY-ADDR-1) 
(IPIN 8 SPY-ADDR-2) 
(IPIN 7 SPY.ADDR-3) 
(IPIN 6 SPY-ADDR-4) 
(IPIN 5 SPY-AODR-5) 
(IPIN 4 SPY-READ L) 
(IPIN 3 SPY-URITE L) 
(IPIN 2 SPY-SELECTED L> 
(OPIN 18 SPY-URITE-NET-CNTRL L) 
(OPIN 17 SPY-READ-NET-STATUS L) 
(OPIN IB SPY-READ-NET-SIGNALS L) 
(OPIN 15 SPY-NET-RESET L) 
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;pin 19 spare 

(OPIN 12 SPY-URITE-BOARO-SELECT L) 

(FIELD SPY-ADDR SPY-ADOR-5 SPY-ADOR-4 SPY.ADOR-3 SPY.ADDR-2 SPY-AODR-l SPY-ADOR-0) 

;; 50>ead - net-signals, write - board select 
s; 51 read « net-status, write « net-control 

(SETQ SPY-READ-NET-SIGNALS (AND SPY-READ SPY-SELECTED (FIELD SPY-ADDR #o50))) 

(SETQ SPY-URITE-BOARO-SELECT (AND SPY-IJRITE (FIELD SPY-ADDR #o50))) 

(SETQ SPY-REAO-NET-STATUS (AND SPY-READ SPY-SELECTED (FIELD SPY-ADDR MoSl))) 

(SETQ SPY-URITE-^T-CNTRL (AND SPY-URITE SPY-SELECTED (FIELD SPY-ADDR *o51})) 

(SETQ SPY-NET-RESET (AND SPY-URITE SPY-SELECTED (FIELD SPY-ADDR i^oSl) SPY-7)) 

:; end of def ini tion 

SCRC : <LMI0B>IISPY2 • PAL ; 21 

;-«- node:LISP; PackagetUSER; Base: 18 -»- 

;PAL for SPY DHA control 

(DEFPAL NSPY2 PAL1SL8 
(IPIN 11 FEP-USING-NET) 
(I PIN 9 FEP-nONITORING-NET) 
(IPIN 8 SPY-DHA-BUSY L) 
(IPIN 7 SPY-DHA-ENB) 
(IPIN 6 NET-RCV-ENABLE) 
(IPIN 5 SPY-SELECTED L) 
(IPIN 4 NET-BYTE-END) _ , 
(IPIN 3 NET-PKT-BEING-XnTD L) 
(IPIN 2 NET-COLLISION) 
(IPIN 1 SET-NET-SKIP-CDND L) 
(IPIN 13 NET-XriT-LAST) 
(IPIN 14 FEP-NET-P<T-RCVD} 
(IPIN 15 LOAD-NET-SH) 
(IPIN 16 NET-CLK) 

(DPIN 18 FEP-SET-NET-XnT-LAST L) 
(OPIN 17 NET-SPY-DflA-SYNC L) 

(OPIN 19 NET-SPY-OE L) 
(OPIN 12-N£T-SPY.DnA-EUSY) 

(SETQ ^£T-XnT.ENABLE (NOT NET-RCV-ENABLE) ) 

(SETQ FEP-HAS-NET (AND FEP-USING-NET SPY-DflA-ENB SPY-SELECTED)) 

(SETQ FEP-SET-NET-XHT-LAST 
(AND NET-XnT-ENABLE 
FEP-HAS-NET 
NET-P<T-BEING-XnTD 

(OR (NOT SPY-DHA-BUSY) NET-CXLISION) ?part of jamming kludge, namely 

(NOT NET-XriT-LAST) ) ) scollieions set the end flag 

(SETQ NET-SPY-DTIA-BUSY (AND NET-RCV-ENABLE SPY-SELECTED 

(OR FEP-USING-NET FEP-MONITORING-NET) 

SPY-DflA-ENB 

(NOT FEP-NET-PKT-RCVO) 

(NOT SET-NET-SiCIP-COND))) 

(SETQ NET-SPY-OE 

(AND SPY-DHA-ENB SPY-SELECTED 

(COND (NET-RCV-ENABLE (OR FEP-USING-NET FEP-nONITORING-NET) ) 
(NET-XnT-ENABLE (AND FEP-USING-NET SPY-DflA-BUSY)) ))) 

(SETQ NET-SPY-DHA-SYNC 

(AND SPY-DHA-ENB SPY-SELECTED 
(CONO (NET-RCV-ENABLE 

(AND NET-SYTE-END (OR FEP-USING-NET FEP-nONITORING-NET) )) 
(NET-XttT-ENABLE (AND FEP-USINC-WET 

iDR (AND LOAO-NET-SH SPV-DnA-BUSY) 
(AND NET-CDLLISION 
SPY-DHA-BUSY 
NET-CLK))))))) 

; ; end of def ini tion 

SCRC : <LMIOB>NSTS .PAL : 11 

;-«- node: LISP; PackagetUSER; Base: 10 -«- 
;PAL decoding aisc control signals 
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(DEFPAL NSTS PAL1SL8 

(I PIN 1 NET-FEP-RCV-^NABLE) 
(IPIN 2 NET-CPU-RCV-ENABLE) 
(IPIN 3 NET-COLLISION) 
UPIN A NET-BUFFER-OV£RfLOU) 
(IPrN 5 NET.PREAnBLE^RRQB\ 
< IPIN 6 NET.PICT-RCYD) 
(IPIN 7 LB-RESET L) 
(IPIN 8 SPY-NET-RESET L) 
(IPIN S LB-DATA-14) 
(IPIN 11 URITE-rET-CNTRL L) 

(IPIN 13 FEP-USING.NET) 
(IPIN 14 NET-ALIGN-ERROR) 
(IPIN 15 NET-CRC-ERROR) 
;I/OPIN 16 spare 

(OPIN 19 SET-NET-SkCIP-COND U 
(OPIN 18 NET.RCV-ENABLE L) 
(OPIN 17 NET-XflT-ENABLE L) 
(OPIN 12 NET-RESET L) 

(SETQ CPU-NET-RESET (AfO LB-DATA-14 URITE-NET-CNTRL) ) 

(SETQ NET-RESET (OR LB-RESET 

SPY-NET-RESET 
CPU-NET-RESET)) 

(SETQ NET-RCV-ENABLE (COND (FEP-USING-NET NET-FEP-RCV-ENABLE) 

((NOT FEP-USING-NET) fCT-CPU-RCV-ENABLE) ) ) 

(SETQ NET-XnT-ENABLE (NOT NET-RCV-ENABLE) ) 

(SETQ SET-f€T-S»CIP-COND (OR NET-PKT-RCVD 

NET-CRC-ERROR 
NET-ALIGN-ERROR 
NET-PREAMBLE-ERRDR 
NET-BUFFER-OVERFLOU 
NET-COLLISION)) 

(SETQ CLEAR-NET-UA»CEUP (OR CPU-CLEAR-NET-UAKEUP 

SPY-NET-RESET) ) 

; ; •nd of def ini t ton 

SCRC : <LMIOB>NTAS)C. PAL ; 1 1 

;-»- nod8:LISP; P«ckaoe:USER; Bat«:18 -«- 

;PAL for d«t«r«ining uhen task uaksups should happen for the net* 

The netuork task uakee up when a word of data has been received or when 
the interface has room in its buffer when transmitting. Transmitting 

?ets started by setting XttT REQUEST in the control register and enabling 
he dma microtask. The first wakeup wt M then happen after any uait for 
the cable to become idle and when the fvr«t preamble word gets transmitted, 
Uhile the second preamble word is being aent« a dma cycle ts done as a 
result of the task wakeup, which (oads the data buffer. At the end of 
the second preamble word, this data is loaded in to the holding buffer/ 
shift register, a task wakeup is done, etc. Uhen the last word is dma'ed 
NET XnT LAST must be set by a NET END cycle. This is concurrent with the last 
dea cycle. There will be a task wakeup after this word is sent which 
:;; should be ignored. After this last data word, a CRC word is sent. A task 
;;; wakeup then occurs to tell the processor that it can start a new packet 
or switch over to receive »ode. 

The receive side is siiipie. Task wakeups happen when data is available, 
and errors or packet done cause a skip condition. If the processor decides 
that it doesn't want to receive the whole packet, it does a NET END cycle 
which causes NET PICT BEING IGNORED to get set for the duration. The hardware 
continues to receive the packet (perhaps for the sake of the listening FEP) 
and will generate a new task wakeup (if enabled) after the last word has been 
received, so the processor can reset things, attempt a transmit, etc. 

The only other anomalous wakeup occurs when XTIT ENABLE hae been set and 
transmitting hasn't started uet anxi DATA VALID comes on, indicating that 
data is being received. In this case, the task should punt getting 
ready to transmit and switch back over to receive mode (is this tricky to 
do?). Part of the preamble wi M be lost, but this Is no big deal. This 
situation may not happen all that infrequently if the net is being pounded 
on hard* 



(DEFPAL NTAS< PAL1GL8 jPALlSLSA actually 

(IPIN 11 NET-RCV-ENABLE) 
(IPIN 9 NET-ACTIVE-CYCLE) 
(IPIN 8 NET-DATA-CYCLE) 
(IPIN 7 REAO-NET-BUF L) 
(IPIN 6 URITE-NET-BUF L) 
(IPIN B NET-UORD-ENO L) 
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(IPIN 4 NET-PKT-BEING-IGNORED) 
(IPIN 3 NET-PJCT-BElNG-XnTD L) 
(IPIN 2 NET-DATA-VALID) 
(IPIN 1 NET-BACKOPF-T I PIER-DONE L) 
(IPIN 13 NET-BACKOFF-TlflER-ENB) 
(IPIN 44 NET-CABLE-BUSY) 
(IPIN 15 NET-RESET L) 
(IPIN le FEP-USING-N£T L) 

(OP IN 12 SET-NET-UA<EL^ L) 
(OPIN 19 SERVICING-NET-BUF L) 
(OPIN 18 NET-CABLE-CTR-ENB I) 

(SETQ hET-XHT-ENABLE (NOT NET-RCV-ENABLE)) 

;;; Save a gate 

(SETQ NET-CABLE-CTR-EN8 (OR NET-BACKOFF-TinER-ENB (NOT FET-CABLE-BUSY) ) } 
(SETQ SERVICING-NET-BUF 

^^ J^^S Kil-5£M^AS'-^ ^OR READ-NET-BUF NET-ACTIVE-CYCLE)) 
(AND NET-XnT-ENASLE (OR URITE-NET-BUF NET-DATA-CYCLE)))) 

(SETQ SET-NET-UAICEUP 

(AND (NOT FEP-USING-NET) 
(NOT NET-RESET) 
^°^ {^^5 N|J-BAC<OFF-TinER-ENB N£T-BAC<OFF-TinER-DONE) 

(AND NETlxnTrlNABd ^^^^ ^^^-^^^ -BEING- IGNORED) NET-UORD-ENO) 
(COND (NET.P<T-BEING-XnTO NET-UORD-ENO) 

((NOT NET-PKT-BEING-XnTD) NET-DATA-VALID)))))) ;s„itch to rev node 

;: end of definition 

SCRC : <LMUCODE>MASK . LISP : 

; -«- flodeiLtsp; Package:Uaer; BaeerS -«- 

; Program to nake the sask proas. Sane package as PROHP. 

•Arrays containing the 0871 ?8H data 

dcfvar aaskd (make-array 2048, '.-type 'art-fib)) 

(defvar .askl make-array 2248. ' ; type 'art-lb ) 

defvar .askZ make-array 2848. 'itCpe 'art-Sb ) 

(defvar wskS (raake-array 2048. 'stype •art4b}) 

m 

(declare (ftxnum n r s rotate value mask)) 

m 

(defMcro <- (argl arg2 «rest more-args) 

(cond Unu I more-arge) Mnpt (> ,argl ,arQ2))) . 
(t (and (not T> argl ,arg2)} 

(<• ,arg2 . ^more-args) ) ) )) 

(defun store-mask (r r rotate value) 

(or (<- r 37 (ferror nil "<vS bad value for R" r)) 
(cr (<- s 37) (ferror nil "-.S bad value for 5- « 

s: ft :iis:i:iR?a 

f"J 5? IM ^3fue) ma5k2 adr) 
(aset (Idb 3010 value) maskS adr))) 

*c*e fun fetch-mask (r s rotate) 

(dpb (aref maskS adr) 3010 

(dpb (aref mask2 adr) 2010 

(dpb (aref cisskl adr) 1010 
(aref mask0 adr)))))) 

(defun setup-fflask-proffls 
' Vi "^»"otatcd masks are simple enough 

(loop for S from to 37 ^nougn 

as mask - 1 then (U (» mask 2)) 
do (loop for r from to 37 
tk- * * -i ^° (atore-mask r s mask))) 

'(l5Sp'fo?1^?of ?o^37'' '^^ "rap-around bytes, probably unnecessary 
«s mask - 1 then (1+ (« nask 2)) ^"-' 

do (loop for r from to 37 

as m . mask then (+ {logandtf. (1- 1^32.) (» m 2)) 
^- / * (I do 3701 «)) 

do (store-mask r s 1 m) j ) > 

(setup-mask-proms) 
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? Function to print them out «ince we can't progpaa the« oupb«Iv«« right now. 
(defun print-nask-proms (file &aux (base 8)) 
iwi th-open-f » le (standard-output file ': print) 
(loop for prom in ' (maskS nasKl masK2 masKS) 

do (format t "-^A Prom:--2X-»15<0ctal Location*>'-15<Hex Locat ion^>*15<0ctal Content»*>^ 
15<HeK Contents- 
(sctq prom (sumeval prom)) 
(dotimes (i 2^48.) 

(format t *'*150*12X" i) 
(hex-print i 3) 

(format t "^ISO-^ISX" (aref prow D) 
(hex-print (aref proa i) 2) 
(terpri)) 
(tgo tf\pagel))) 

(defun hex-print (number n-digits) 
(loop repeat n-dlgtts 

as divisor » i^ IS. (1- n-digits)) then (// divisor IB.) 
do (tuo (nth (\ (// number divisor) IS.) 

' it(/2 u/i nn u/2 ujk u/s u/z un n/z tf/s u/x n/z u/c u/u n/E »/n )))) 
SCRC : <LMI0B>IIXMT1 . PAL ; 16 

t-«- riodtiLISP; PackagetUSER; Bate: 18 -»- 
jTraniaittar control 



;;NOTES: jamming uorks by setting NET XTIT LAST via FEP SET NET XHT LAST 
;;Then, the inverted CHC is sent (so it doesn't look like a good packet). 

^^^'l^SViu^^II/ib^^^ . . :PAL16R4A. actually 

; (IPIN 1 NET-Xni-CLK L) ;CLK input 



(IPIN 2 NET-XnT-ENABLE) 
(IPIN 3 NET-XnT-REQUEST) 
(IPIN 4 NET-RESET L) 
(IPIN 5 NET-COLLISION) 
(IPIN 6 NET-CABLE- I OLE L) 
(IPIN 7 NET-SPY-OE L) 
(IPIN 8 NET-BYTE-CNT.3 L) 
(IPIN 9 Q-Q-NET-BYTE-END) 
(IPIN 12 NET-XHT-LAST) 
(IPIN 13 Q-NET-BYTE-END) 
(IPIN 18 FEP-USING-NET> 

CRPIN 14 NET-XnT-STATE-8) 

(RPIN 15 NET-XHT-STATE-l) 

(RPIN IS NET-PREATIBLE-DAIA L) 

(RPIN 17 NET-PKT-BEING-XnTD L) 

(OPIN 19 aEAR-NET.XnT-REtX£ST L) 

(FIELD XriT-STATE NET-XHT-STATE-l f€T-XnT-STATE-8) 

(SETQ XriT-ERROR (OR NET-COLLISION 

(NOT NET-XnT-ENABLE) 
NET-RESET)) 

(SETQ XriT-QUIT (OR NET-XTIT-LAST 
XHT-ERROR) ) 

(SETQ START-XnT (AND (IF FEP-USING-NET NET-SPY-OE 

NET-XHT-REQUEST) 
NET-CABLE- IDLE 
(NOT NET-PKT-BEING-XnTD) 
(NOT XriT-QUIT))) 

(SETQ UORD-END (AND NET-8YTE-CNT-3 Q-NET-BYTE-ENO) ) 

(SETQ NET-PICT-BEING-XnTD 
(AND (NOT NET-RESET) 
NET-XMT-ENABLE 
(OR START-Xni 

(AND NET-PKT-BEING-XnTD -hold until CRC goes out 

(NOT (AND UORD-END (FIELD XHT-STATfe 3))))))) * 

(SETQ CLEAR-NET-XnT-REQUEST (OR NET-P»CT-BEING-XnTD XTIT-ERROR)) 

(SETQ NET-PREAMBLE-DATA • 
(AND (NOT NET-RESET) 

(OR START-XnT NET-PICT-BEING-XHTD) 

(FIELD Xnr-STATE (0 1)} 

(OR (NOT NET-PREAHBLE-DATA) ttoaaie 

(AND (FIELD xm -STATE 1) tsend two ones at the end 

NET.BYTE-CNT-3 Q-Q-NET-BYTE-END)))! 

; If in state 8 (transmit first preamble word), go to state I when UORD END. 
! f m state 1 transmit second preamble word), go to state 2 when UORD END. 
1 If in state 2 (.transmit jacket data), go to state 3 when NET XHT LAST. 
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If in state S (transmit CRC data), go to state 8 uhen WORD END. 
Note, that when FEP sets NET KUT LAST, eoine randoa extra bytes mau 
get sent to round up to a word boundary. 

(SETQ NET-XnT-STATE-e 

(AND (NOT NET-RESET) 
NET-XnT-ENABLE 
(IF NET-XnT-STATE-1 
CIF WORD-END 

(AND NET-XriT-LAST (NOT NET-XTIT-STATE-B) ) 
NET-XnT.STATE-0) 
(XOR WORD-END NET-XnT-STATE-B)))) 

(SETQ NET-XnT-STATE-1 

(AND (NOT NET-RESET) 
NET-XflT-ENABLE 

(XOR (AND UORD-END NET-XttT-STATE-e) 
NET-XHT-STATE-l))) 

;; end of def ini t ion 

SCRC:<LHI0B>NXMT2,PAL;7 

{-«-. rioderLISP; Package: USER; Base: 18 -«- 

;; Counter to determine cable idleness 

(DEFPAL NXnT2 PAL1GR8 

(IPIN 5 NET-CABLE-CTR-ENB L) 
(IPIN 6 NET-RESET L) 
(IPIN 7 NET-BACKOFF-TirER-ENB) 
(IPIN 8 NET-DATA-VALID) 
(IPIN 3 NET-CABLE-BUSY) 

(RPIN 18 BfT'E^U^"^^^ ^^ ^^**° ^^ ^AC^O^*" TiriER DONE L 

(RPIN 17 BIT-5 L) 

(RPIN le BIT.4 L) 

(RPIN 15 BIT-3 L) 

(RPIN 14 BIT-2 L) 

(RPIN 13 BIT-1 L) 

(RPIN 12 BIT-8 L) 

(FIELD COUNT BIT-6 BIT-5 BIT-A BIT-3 BIT-2 BlT-1 BIT-8) 

;;: Count 96. clock ticks after NET-CABLE -BUSY goes away. 
;;; A J so, count clock ticks for backoff tiner. 

(SETQ COUNT-ENABLE 

(AND (NOT NET-RESET) 

NET-CABLE-CTR-ENB s count if enabled 
(NOT KET-CABLE-IDLE))) ;and not done 

(SETQ BIT-8 (AM3 COUNT-ENABLE 

(XOR BIT-8 T))) 

(SETQ BIT-l (AND COUNT-ENABLE 

(XOR BIT-1 BIT-8))) 

(SETQ BIT-2 (AND COUNT-ENABLE 

(XOR BIT-2 (AND BIT-1 BIT-8)))) 

(SETQ BIT-3 (AND COUNT-ENABLE 

(XOR BIT-3 (AND BIT-2 BIT-l BIT-8}))) 

(SETQ BIT-A (AND COUNT-ENABLE 

(XOR BIT-A (AND BIT.3 BIT-2 BIT-1 8IT-8)))) 

(SETQ BIT-5 (AND COUNT-ENABLE 

(XOR BIT-5 (AND BIT-4 BIT-S BIT-2 BIT-1 BIT-8)))) 

(SETQ BIT-6 (AND COUNT -ENABLE 

(XOR BIT-S (AND BIT-5 BIT-4 BlT-3 BlT-2 BlT-1 BIT-B)))) 

;; Uhen used as a backoff timer, NET CABLE IDLE gets asserted for one clock period 

:; *iV*Jl long enough to cause a NET UAKEUP), then the counter is reset by 

;; NET CABLE IDLE coming on, and counting continues. To get accurate backoff 

;; timings, NET RESET should presumably be hit to reset the counter, unless 

;; you want the timing to date back to the last CABLE BUSY condition. 

(SETQ NET-CABLE- I OLE 

(OR (AND NET-BAC<DFF.TiriER-ENB jif In use as backoff timer 

(FIELD COUNT 127.)) ;count 127. ticks 

(AND (NOT NET-BACKOFF-TinER-ENB) otherwise 

(NOT NET-DATA-VALID) -if not receiving 

{K§\r^f^;9SPk^7gHiY^ -3"^ *h« "t)le is not busu 

(FIELD COUNT B5.))))) ;ihen raise flag. 
:; end of definition 
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SCRC:<LMIOB>VCLK,PAL:C 

|.«- node:LISP; P«cktg«:US£R; BaaazlS -«- 

tPAL For decoding cycle types and tgnc bit* 

(DEFPAL VCLK PALIBRS 

t (IPIN 1 VD-SSEQ-CL*C L) jedvanca state only when not waiting 

CIPIN 2 SD-0) 

CIPIN 3 SD-1) 

(IPIN 5 SO-8) 
(IPIN S SD-9) 
(IPIN 7 SO-10) 
(IPIN 8 VO-SREG-ENB) 
(IPIN 9 VO-SSEQ-ENABLE) 

(RPIN 19 BLAN»<r) 
(RPIN 18 V-SYNC) 
(RPIN 17 H-SYNC) 

(RPIN 15 VD-PRX-CvaE L) ;3 

(RPIN 14 VD-LPTR-CYCLE L) ;2 

(RPIN 13 VD-REFR-CYCLE L) ;1 

(RPIN 12 VD-OISP-CYCLE) $0 

(FIELD CYCLE-TYPE SO-1 50-0) 

;; 10«b)ank, 9»v sync, 8» h sync 

(SETQ BLANK (AND VO-SSEQ-ENABLE (CO^C (VD-SREG-ENB SD-10) 

(WOT VD-SREG-ENB) BLANK)))) 

(SETQ V-SYNC (AND VD-SSEQ-ENABLE (COND (VD-S?^G-ENB SD-S) 

( imi VD-SREG-ENB) V-SYNC) ) ) ) 

(SETQ H-SYNC (AND VD-SSEQ-ENABLE (COND (VD-SREG-ENB SO-8) 

((NOT VD-SREG-ENB) H-SYNC)))) 

(SETQ VO-PROC-CYCLE 

(AND VD-SSEQ-ENABLE (COND (VO-SREG-ENB (FIELD CvaE-TYPE 3)) 

((NOT VD-SREG-ENB) VD-PROC-CYCLE) ) )) 

(SETQ VD-LPTR-CYCLE 

(AND VD-SSEQ-ENABLE (COND (VD-SREG-ENB (FIELD CYCLE-TYPE 2)) 

((NOT VD-SREG-ENB) VD-LPTR-CYCLE)))) 

(SETQ YD-REFR-CYCLE 

(AND VD-SSEQ-ENABLE (COND (VD-SREG-ENB (FIELD CYCLE-TYPE D) 

((NOT VD-SREG-ENB) VD-REFR-CYCLE)))) 

(SETQ VD-DISP-CVaE 

(AND VD-SSEQ-ENABLE (COND (VD-SREG-ENB (FIELD CYCLE-TYPE 0)) 

((NOT VD-SREG-ENB) VD-OISP-CYCLE)) ) ) 

;; end of definition 

SCRC:<LMI0B>VCLIC3.PAL;1 

s-«- node:LISP; Pack«ge:US£R; Base: 10 -«- 

• PAI For decoding cycle types and sync bits., ^Appears on dwg. VCLK. 

(DEFPAL VCLK PAL16R8 

; (IPIN 1 VO-SSEQ-CLK L) :advance state only when not waiting 

(IPIN 2 SD-0) ^ 

(IPIN 3 SD-1) 

(IPIN 5 SD-8) 
(IPIN e SD-9) 
(IPIN 7 SD-10) 
(IPIN 8 VD-SREG-ENB) 
(IPIN 9 VD-SSEQ-ENABLE) 

. (RPIN 19 BLANK) 
(RPIN 18 V-SYNC) 
(RPIN 17 H-SYNC) 

(RPIN IS FRAflE-BIT) ;3 

(RPIN 15 TAG-2 L) ;2 

(RPIN 14 TAG-1 L) ;1 

(RPIN 13 TAG-0 L) ;0 

(RPIN 12 VD-SREG-ENB) 

(FIELD CYCLE-TYPE SO-1 SO-0) 

;; 10«blanK, 9-v sync, 8- h sync 

(SETQ BLANK (AND VD-SSEQ-ENABLE (COND (VD-SREG-ENB SD-10) 

((NOT VD-SREG-ENB) BLANK)))) 
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(SETQ V-SYNC (AND VD-SSEQ-ENABLE (COND (VD-SREG-ENB SD-3) 

(SETQ H-SYNC (AND VD-SSEQ-ENABLE (COND {^g?ye:rNpii^i '■=^"'' 

{(NOT VD-SREG-ENB) H-SYNC)))) 

(SETQ TAG-e (FIELD CYCLE-TYPE 0)) 

(SETQ TAG-1 (FIELD CYCLE-TYPE D) 

(SETQ TAG-2 (FIELD CYCLE-TYPE 2)) 

;nAYBE THE FRAflE BIT SHOULD BE THE SATIE AS ONE OF THE TAGS. 

(SETQ FRAHE -BIT (FIELD CYCLE-TYPE 3)) 

(SETQ VD-SREG-ENB (OR (NOT VD-SREG-ENB) SD-B))) 

:; end of definition 

SCRC : <LMIOB>VDCCTL . PAL ; 3 

t-«- ttodciLISP; PackagetUSER; BASE:18 -»- 

;PAL For control! inq the two word "cache" at the LBUS interface to the 
;TV Beaory on the REV-3 I/O board. PAL appears on dug. VDDCTL. 

(DEFPAL VOCCTL PAL16RS 

; (INPIN 1 -LB STATE CLOCK) 

(IPIN 2 CPU-DATA-CYCLE L) 
(IPIN 3 CPU-URITE-DH L) 
(IPIN 4 CPU-URITE) 
(IPIN 5 LB-URITE L) 
(IPIN 8 LB-AODR-09) 
(IPIN 7 CPU-ADDR-C8) 
(IPIN S LB-TV-REQ L) 
(IPIN 9 CACHE-HIT L) 

(OP IN 19 CACHE-ACT-EN L) 

(RPIN 18 ODO-CACHE-URITE) 
(RPIN 17 ODD-OE L) 
(RPIN IB EVEN-OE L) 
(RPIN 15 CACHE-DIRTY L) 
(RPIN 14 EVEN-CACHE-WRITE) 
(RPIN 13 CACHE-ACTIVE-CYCLE L) 

(SETQ EVEN-CACHE-URITE (AND LB-TV-REQ CACHE-HIT LB-URITE (NOT LB-ADDR-80) 

(NOT CAC^€-DIRTY))} 

(SETQ CACHE-DIRTY (OR (AND CACHE-HIT LB-TV-REQ LB-URITE (NOT LB-AODR-09) 

(NOT CACHE-DIRTY)) 
(AND CACHE-DIRTY (NOT CPU-URITE-DTI))) 

(SETQ CACHE-ACTIVE-CYO-E fOR (AND CACHE-HIT LB-TV-REQ (NOT LB-ADDR-00) LB-URITE 

(AND CACHE-HIT LB-TV-REQ (NOT LB-URITE) (NOT CACHE-DIRTY)))) 

(SETQ EVEN-OE (OR (Ahg CACHE-ACT! VE-CVaE (NOT CPU-ADDR-00) (NOT CPU-URITE)) 
(AND CPU-OATA-CYCLE (NOT CPU-ADDR-00) (NOT CPU-URITE) )) ) 

(SETQ OOO-OE (OR (AND CACHE-ACTIVE-CYCLE (NOT CPU-ADOR-00) (NOT CPU-URITE)) 
(AND CPU-DATA-CYCLE CPU.ADDR-00 (NOT CPU-URITE)))) ""*""'' 

(SETQ CACHE-ACT-EN (OR (AND CACHE-HIT LB-TV-REQ (NOT LB.ADDR-00) LB-URITE 

(NOT CACHE-DIRTY)) 
(AND CACHE-HIT LB-TV-REQ (NOT LB-URITE) (NOT CACHE-DIRTY)))) 

:;END OF DEFINITION 

SCRC : <LMIOB>VDDADR . PAL : 2 

:-»- HoderLISP; PackagetUSER; BASE:10 -»- 

jPAL for controlling the Line Index Table. See dwg. VDDAOR. 

(DEFPAL VOOADR PAL1SR4 

; {IPIN 1 LB-STATE-CLOCK L) 

; (IPIN 11 GND) output enable. 

(IPIN 2 LIT-RESET L) 
(IPIN 3 REFRESH-On-ACTIVE L) 
(IPIN 4 TV-Dn-ACTIVE L) 
(IPIN 5 CPU-Dn-ACTIVE L) 
(IPIN S REFRESH-DATA-CYCLE L) 
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(IPIN 7 TV-DATA-CYCLE L) 
(IPIN 8 CPU-OATA-CYCLE L) 
(IPIN 9 LIT-REQ L) 
(IPIN 12 DTID-IS) 

(RPIN 16 ODD-CHUNK-CDUNT L) 
(RPIN 15 LIT-DATA-CYCLE L) 
(RPIN 14 tlT-Dn-ACTIV£ L) 

(OPIN 19 Dn-DATA-CYCLE) ; INTERNAL USE 

:00D CHUN)C COUNT means there are an odd number of 64-pixel chunks that are to be read froa 

;the TV aea during this scan line. DflD 16 it the LSB of the chunk count. This info 

;Bust be kept around so that the FIFO %tuffBr knows hou to ignore the last chunk and to 
jnot put it in the FIFO, 

(SETQ OOO-CHUNIC-COUNT (OR (AND OMD-IS LIT-Ofl-ACTIVE) stets the bit 

(AND 0EM3-CHUNK-COUNT (NOT UT-OO-ACTIVE) ))) ; ho Ids it on 

;LIT DATA CVaE happens one LBUS STATE after the LIT ACTIVE cycle. 

(SETQ LIT-OATA CYCLE (AND LIT-OO-ACTIVE (NOT LIT^ATA^YCLE))) 

;LIT on CYCLE is the highest priority thina that can happen to the TV aea. At the end of 
;a scan line, LIT REQ is asserted. This PAL gets the TV aen so it can go into the LIT 
;and find the starting address for the next scan line aegaent. 

(SETQ LIT^Dn-ACTIVE (AND LIT-REQ (NOT DTI-ACTIYE-CYCLE})) 

(SETQ On-DATA-CYCLE (OR LIT-OATA-CYCLE TV-DATA-CVaE CPU-DATA-CYaE REFRESH^ATA-CYCLE) ) 

:;END OF DEFINITION 

SCRC : <L>riOB>VDMADR . PAL ; 3 

;-»- nodexLISP; PackagesUSER; BASE:10 -«- 

sPAL for controlling tha write enables and bank eefects of the TV aeaoru^ 

{the CPU READ CLOOC. and CPU data output enable* Pal appears on dug. VOrUOR.OUG. 

(DEFPAL VOriADR PAL1BL8 

(IPIN 1 LIT-BN<-SEL) 
(IPIN 2 CACHE-DIRTY L) 
(IPIN 3 S+28-NS) 
(IPIN 4 STROBE) 
(IPIN 5 TV-On-ACTIVE L) 
(IPIN 6 CPU-URITE) 
(IPIN 7 LIT-Dn-ACTIVE L) 
(IPIN 8 CPU-On-ACTIVE) 
(IPIN 9 CPU-ADOR-01) 

(IPIN n cpu-ADOR-ea) 

(OPIN 18 UE-0 L) 
(OPIN 17 WE-l L) 
(OPIN 16 lJE-2 L) 
(OPIN 15 l£-3 L) 
(OPIN 14 CPU-URITE-On L) 
(OPIN 13 BANK-0 L) 
(OPIN 19 BANK-l L) 
(OPIN 12 CPU-RD-CLK L) 

(FIELD CPU-ADORESS CPU-ADOR-01 CPU.ADDR-00> 
tNoraal write 

(SETQ UE-a (OR (AND CPU-URITE CPU-OO-ACTIVE (FIELD CPU-ADORESS 0)) 
;Urite thru cache if it Is dtrtg. 

(AND CPU-URITE CPU-Ott-ACTIVE (NOT CPU.ADDR-01) CACHE-DIRTY))) 

(SETQ lC-1 (OR (AND CPU-URITE CPU-OH-ACTIVE (FIELD CPU-ADORESS 1)))) 

CSETQ UE-2 (OR (AND CPU-URITE CPU-Ott-ACTIVE (FIELD CPU-ADDRESS 2)) 

(AND CPU-URITE CPU-DH-ACTIVE CPU-ADOR-01 CACHE-DIRTY))) 

(SETQ IC.3 (OR (AND CPU-URITE CPU-DH-ACTIVE (FIELD CPU-ADDRESS-3) ) ) ) 

lEnable the outputs of the latches froa the LB DATA bus to the DMO bus. 

(SETQ CPU-WITE-On (AND CPU-URITE CPU-DH-ACTIVE)) 

;Bank select. For the TV read cycles the bank switch happens as a function of the 
; del aged strobe pulse. 

(SETQ BANK-0 (OR (AND CPU-Otl-ACTIVE (NOT CPU-URITE) (NOT CPU-ADOR-01)) 
(AND LIT-On-ACTIVE (NOT LIT^N*C.SEL)) 
(AND TV-On-ACTJVE (NOT S+20-NS)))) 
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(SETQ BANK-1 (OR (AND CPU-DTI-ACTIVE (NOT CPU-URITE) CPU-ADOR-ei) 
(AND LIT-Dfl-ACTIVE LIT-BNK-SEL) 
(AND TY-Dn-ACTIVE S+28.NS) 

;CIocK8 the CPU read reyisters chock ful! of data at the leading edge of the 
;etrobe free the DRArt tieer eodule if a CPU read yas in progress. 

(SETQ CPU-RO-CLK (AND CPU-DM-ACTIVE (NOT STROBE) (NOT CPU-URITE))) 
5:END OF DEFINITION 

SCRC : <LMIOB>VDMAG .PAL ; 8 ~^ ' 

;-»- node:LISP; Package:USER; Base: 18 -*- 
;PAL For decoding cycle types and sync bits 

(DEFPAL VOnAG PAL1SR8 

• iil^h%^JP^^^'^^ ^^ ^advance state ontg when not watting 

UrlN 2 SD-o) 

(IPIN 3 SD-1) 

(IPIN 4 SD-2) 

(IPIN 5 SD-3) 

(IPIN 6 SD-4) 

(IPIN 7 SD-5) 

(IPIN 8 SO-S) 
; (IPIN 3 VD-SSEQ-ENABLE) 

(RPIN 19 VO-SREG-ENABLE) 
(RPIN 18 OnAG.CI) 
(RPIN 17 DnAG.Z L) 
(RPIN 16 DHAG.FE L) 
(RPIN 15 DTIAG.PUP) 
(RPIN 14 DHAG.RE L) 
(RPIN 13 OnAG.Sl) 
(RPIN 12 DTlAG.Se) 

'(k?8'?D!ife^!EN?S!E'='f§^"(flS?"v!?sy!E.!iSSii? lile5',''^-"'='" °^ ""• '" *^- 2910 

(FIELD CYCLE-TYPE SO-2 SD-1 50-8) 
(FIELD DflAG-OP SO-5 SO-4 SD-3} 

;; Cycle type CYCLE -TYPE OTIAG-QP 2911 Controls 

ii Oisplir' 1 ? Sirii'" , select input 

;; ^e p before LPTR ! | EJ^Sl.FE j ^^0^1',' '^ 

I; Rel?esh after LPTR I I lliHH^^"^ I {§§' IT,^ '°^^ 

;; Line Start 8 5 CSS FrPUP AR 'nSsS 

^' ^^'p °^ *^^"« 2 I ciiz :fI:pup.re ; 8?'pCsh' 

;; Note: On processor cycles, the 2911 is not clocked, but just passes the D input 

;; to the output, newopy access for LPTR cycles barely aake it by the end of TB. 

;:; 2911 Controls 

(SETQ DnAG.CI (COND ((NOT VD-SREG -ENABLE) DriAG.CI) 
(VD-SREG-ENABLE 

(SETQ DflAG.Z (COND ((NOT VD-SREG-ENABLE) DTIAG.Z) 
(VD-SREG-ENABLE 
(AND (FIELD CYCLE-TYPE 2) 

(FIELD DflAG-OP S))))) $ junp to zero 

(SETQ DttAG.FE (COND ((NOT VD-SREG-ENABLE) C^G.FE) 
(VD-SREG-ENABLE 
(AND (FIELD CvaE-TYPE (8 12)) 

(FIELD OftAG-OP (2345 S)))))} 

(SETQ DflAG.Pt^ (COND ((NOT VO-SREG-ENABLE) DtlACPUP) 
(VD-SREG-ENABLE 
(AND (FIELD CYCLE-TYPE (8 12)) 

(FIELD DHAG-OP (3 4 5 5)))})) 

(SETQ DTIAG.RE (COND ((NOT VD-SREG-ENABLE) DHACRE) 
(VD-SREG-ENABLE 
(AND (FIELD CYCLE-TYPE 2) 

(FIELD DHAG-OP (3 6)))))) 

(SETQ DnAG.S8 (COND ((NOT VD-SREG-ENABLE) DtlACSS) 
(VD-SREG-ENABLE 
(AND (FIELD CYCLE-TYPE (8 3)) 
(FIELD OnAG-OP (8 5)))}}) 

(SETQ DttAG.Sl (COND ((NOT VD-SREG-ENABLE) OnAG.Sl) 
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(VD-SREG-ENABLE 
(AND (FIELD CYCLE-TYPE (1 2 3)) 

(FIELD DflAG-OP (8 2 3 4)))))) 

;; end of def ini tion 

SCRC : <LMI0B>VDMCTL1 . PAL ; 2 

-«- node:LISP; PackagetUSER; Base: 19 -»- 

PAL for Lbus/video control signals 

;; OE is grounded, OX is LB-STATE-CLK 

(DEFPAL VDnCTLl PAL1GR4 
; (I PIN 1 LB-STATE -CLK L) 

(IPIN 2 LB-ADDR-0) 

(IPIN 3 LB-ADDR-8-A) 

(IPIN 4 LB-ADDR-18) 

(IPIN 5 LB-ADDR-IS-A) 

(IPIN 6 LB-ADDR-17) 

(IPIN 7 LB-ADDR-17-A) 

(IPIN 8 lO-READ-RQ) 

(IPIN 9 lO-REAO-ACTIVE-CYCLE) 

(IPIN 12 104iRITE.RQ) 

(RPIN 14 VD-READ-HI L) 
(RPIN 15 VD-READ-LO L) 
(RPIN 16 SYNC-nEH-CYCLE L) 
(RPIN 17 SYNC-flEn-UE L) 

(SETQ VD-REAO-LO (OR (AND lO-READ-RQ LB-AODR-18 (NOT LB-ADDR-e)) 

(AND lO-READ-ACTIVE-CYCLE LB-ADDR-18-A (NOT LB-ADOR-e-A)))) 

(SETQ VO-REAO-HI (OR (AND JO-REAO-RQ LB-ADOR-18 LB-ADOR-H) 

(AND IO-fi£AD-ACTlV£-CYCLE LB-ADDR-18-A LB-ADOR-B-A))) 

(SETQ SYNC-riEn-SELECTEO (AND LE-AD0R.17 (NOT LB-ADDR-lSn) 
(SETQ SYNC-HEn-SELECTED-A fANO LB-ADDR-H-A (NOT LB-ADDR-18-A>>) 
(SETQ SYNC-riEH-UE (AWO SYNC -n£n-SEt£C TED lO-URITE-RQ) ) 

(SETQ SYNC-nEn-CYCLE (OR (AND SYNC-flEn-SELECTED I04iRITE-RQ) 

(AND SYNC-nEn-SELECTED lO-READ-RQ) 
(AND SYNC-HEn-SELECTED-A lO-READ-ACTIVE-CYCLE))) 

: ; end of def ini tion 
SCRC : <LMI0B>V0MCTL2 . PAL ; 2 

f->- node:LISP; PackagesUSER; BASEtlB -«* 

tPAL for controlling the state of (AND ACCESS TO) the TV Memory. Pal appears on 
;dug. VOrCTL. 

(DEFPAL VDnCTL2 PAL1SL8 

(IPIN 1 LB-URITE) 
(IPIN 2 CACHE-HIT L) 
(IPIN 3 CACHE-DIRTY L) 
(IPIN 4 LB-TV-REQ L) 
(IPIN 5 REF-REQ L) 
(IPIN 6 CACHE-ACTIVE) 
(IPIN 7 Dn-ACT1V£-CYCL£) 
(IPIN 8 PANIC) 
(IPIN 3 LIT-REQ L) 
(IPIN 11 LB-REFRESH L) 
(IPIN 13 LB-ADDR-00) 
(IPIN 14 CLEAR-LB-UAIT L) 
(IPIN 15 FULLNESS) 

(OPIN 17 CPU-ACTIVE-ENAB L) 
(OPIN 18 REFRESH-ENAB L) 
(OPIN IS REF-REQ-ENAB L) 
(OPIN 12 TV-ACTIVE-ENAB L) 

;Noone etee is requesting the TV Beeory and we Brm not in the eiddte of a cycle. Give 
;the next cycle to the fffo if the fifo ia not full. 

(SETQ TV-ACTIVE-ENAB (OR 4AND (NOT L1T-B£Q) (NOT CPU-REQV (NOT REF-OH-EN) (NOT REF-REQ) 

(NOT FULLNESS) (NOT DH-ACTIVE-CYCLE) (NOT CACHE -ACT I YE)} 

;The fifo is in panic aode. Give it the cycle. 

(AND (NOT LIT-REQ) (NOT DM-ACTIVE-CYaE) PANIC))) 

iCache aies. Cache is eepty. 
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(SETQ CPU-ACT I VE-ENAB (OR (AND (NOT LIT-REQ) (NOT PANIC) (NOT REF-REQ) (NOT Dn-ACTIVE-CYCLE) 

(NOT CACHE-HIT) (NOT CACHE-DIRTY) LB-TV-REQ) 

jCach« tttes. Cache It full, ttust assept write during this cgcle, assert LBUS UAIT. flush 
:cacht. then request another cycle for the CPU, 

(AND (NOT LIT-REQ) (NOT PANIC) (NOT REF-REQ) (NOT DH-ACTIVE-CYCLE) 
(NOT CACHE-HIT) CACHE -DIRTY LB-TV-REQ) 

;Cache is dirty with data in the least significant word. CPU wants to read this data. Data 
;is not yet in the TV aemory. Two birds are killed with one cycle. To the TV men it 
; looks tike a write cycle and the data in the cache is stored m TV Ken. To the CPU it 

''X^?^* *'*^* ^ ^^^^* '*^« ^*** 0" DnD<31:88> bus going to the TV aea is clocked into the 

5 CPU read reg. 

(AND (NOT LIT-REQ) (NOT PANIC) (NOT REF-REQ) (NOT DH-ACTIVE-CYCLE) 
(NOT LB-URITE) CACHE-HIT CACHE-DIRTY LB-TV-REQ 
(NOT CPU-ADDR-00)) 

;Cache is hit. CPU wants to writs data into the high half which is not dirty. Since 
;the next operation will Most likely be at th^ current address plus one, which would 
: cause a eiss, write it thru now. 

(AND (NOT LIT-REQ) (NOT PANIC) (NOT REF-REQ) (NOT Dfl-ACTIVE-CYCLE) 
LB-TV-REQ CACHE-HIT (NOT CACHE-DIRTY.) LB-AODR-BS LB-URITE) 

;Read cycle, cache hit but empty. CPU wants the low half of cache but it is not dirtu. 
jHust go get fresh data. ^w 

(AND (NOT LIT-REQ) (NOT PANIC) (NOT FEf^REQ) (NOT DH-ACTIVE-CYCLE) 
(NOT LB-URITE; cache-hit LB-TV^^Q (NOT CACHE-DIRTY)) 

jLBUS wants to refresh the RAH's and we are not panicking or LITing. Do It. 

(SETQ REFRESH-DH-ENAB (OR (AND (NOT LIT-REQ) (NOT PANIC) LB-REFRESH (NOT Oti-ACTIVE-CYCLE)) 
J A request for RAM refresh has been logged but not honored yet. It is OK now. 

(AND (NOT LIT-REQ) (NOT PANIC) REF-REQ (NOT On-ACTIVE-CVaE)))) 
•f0P^a"«"r* f° '"?^''®*^ *^* ^^' ^^^ sonething More inportant is happening. Log the request 

(SETQ REF-REQ (OR (AND LB-REFRESH LIT-REQ) 
(AND LB-REFRESH PANIC) 
(AND LB-REFRESH DH-ACTIVE-CYCLE) 
(AND REF-REQ (NOT REFRESH-DH-ENAB) ) ) ) 

::END OF DEFINITION 

SCRC : <LMI0B>VDMCTL3 . PAL ; 2 

;-«. node: LISP; Package: USER; BASE: 18 -«- 

:PAL for deciding when to hang the bus. PAL appears on dwg. VDTICTL 

(DEFPAL VOnCTLS PAL16R4 

; (IPIN 1 LB-CLOCK L) NOT LB STATE CLOCK! 
; (IPIN 11 GNO) output enable. 

(IPIN 2 CACHE-HIT L) 
(IPIN 3 CACHE-DIRTY L) 
(IPIN 4 LB-TV.REQ L) 
(IPIN 5 REF-REQ L) 
(IPIN e CACHE-ACTIVE) 
(IPIN 7 DM-ACTIVE-CVaE) 
(IPIN 8 PANIC) 
(IPIN 3 LIT-REQ L) 
(IPIN 12 LB-REFRESH L) 
(IPIN 13 LB-ADDR-88) 
(IPIN 18 FULLNESS) 

(RPIN 17 ASSERT-LB-UAIT L) 

(DPIN 19 CLEAR-LB-UAIT L) ; INTERNAL USE 

(SETQ ASSERT-LB-UAIT (OR (AND LB-TV-REQ DH- ACTIVE -CYCLE) 

(AND LB-TV-REQ LIT-REQ) 
(AND LB-TV-REQ PANIC) 

(AND LB-TV-REQ (NOT CACHE-HIT) CACHE-DIRTY) 
(AND ASSERT-LB-UAIT (NOT CLEAR-LB-UAIT))) ) 



(SETQ aEAR-LB-UAIT (AND ASSERT-LB-UAIT (NOT TV-DH-ACTIVE) )) 
;END OF DEFINITION 
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SCRC : <LMI0B>VFFCTL1 . PAL : 2 

;-»- nodeiLISP; Package.-USER; BAS£:10 -«- 

iPAL For control ling th« RAP! FIFO. Pal appears on dug. VFFCTL. 

(DEFPAL VFFCTL PAL16R4 

; (IPIN 1 PIXEL CL</4 L) iCLXK INPUT 

; (IPIN 11 GNO) tOUTPUT ENABLE 

<IPIN 18 TV-On-ACTIVE-A L) 
(IPIN 13 STROBE-A) 
UPIN 12 S+€8-NS-A) 
(IPIN 2 LAST-CHUN< L) 
(IPIN 3 ODD-CHUNK -COUNT-A L) 
(IPIN 4 FILL -GO) 
(IPIN 5 FIFO-REQ+12) 
(IPIN 6 FILL-ADDR-03) 
(IPIN 7 FILL-ADDR-02) 
(IPIN 8 FILL-ADDR-01} 
(IPIN 3 FILL-ADOR-S0) 

(RPIN 17 ORAIN-CNT-EN L) 
(RPIN 16 FILL-CNT-EN L) 
(RPIN 15 FIFO-URITE L) 
(RPIN 14 LD-VSR L) 

(OPIN 19 FILL-GO-EN) 

(FIELD REG-ADDRESS FILL-ADOR-02 FILL-ADDR-Bl FILL-ADDR-08) 
;Th« OnO ragi start hava baan loaded uith fraah data. Start a FIFO stuff cycle. 

(SETQ FILL -GO-EN (OR (AND S+60-fiS-A (NOT FILL-GO)) 

(AND FILL-GO (NOT UST CHUNK) (NOT (FIELD REG-ADDRESS 7))) 

I This is the last chunk and the chunk count uae even so ue go ahead and load the odd one. 

(AND FILL-GO LAST-CHUNK (NOT ODD-CHUNK-COUNT) 
(NOT (FIELD REG-ADDRESS 7))) 

;This ta the laat chunk and the count was odd ao ua do not load the odd one« 

(AND FILL-GO LAST-CHUNK ODD-CHUNK-COUNT (NOT (FIELD REG-ADDRESS 3))))) 

lUhenever the FIFO request wants 1t» tt gets it* 

(SETQ DRAIN-CNT-EN FIFO-REQ+12) 

;F;ii go enable is asserted and the FIFO request is not happening so urn sight as well 
; start ths cycle nou. 

(SETQ FILL-CNT-EN (OR (AND FIU-GO-EN (NOT FIFO-REQ+12)) 

;Increnent te fill count. 

iAND FILL-GO (NOT FIFO-REQ+12) (NOT UST-CHUNK)) 

;Ue are at the end of a line but this is the even half of the last cycle so that ue can 
tgo anyway. 

(AND FILL-GO (NOT FIFO-REQ+12) (NOT FILL-ADOR.02} 

LAST-CHUNK) 

;Ue are at the end of a line, the odd half of the cycle* and it ia not an odd chunk count. 

(AND FILL-GO (NOT FIFO-REQ+12) UST-CHUNK FILL-ADDR-02 
(NOT ODD-CHUNK-COUNT)) 

; Something is wrong. The counter should a f wags be at REG-ADDRESS when FILL GO la not 
; asserted. Increment it tUl this is true. 

(NOT-FILL-GO) (NOT (FIELD REG-ADDRESS 0))) 

;FIFO URITE always happens when you are filling. It never happens when you are 
Sdraining. 

(SETQ FIFO-URITE (OR (AND FILL-GO-EN (NOT FIFO-REQ+12)) 
(AND FILL-GO (NOT FIFO-REQ+12)))) 

; After you enable the drain count you load the YSR. Pipe delays* 

(SETQ LD-VSR DRAIN-CNT-EN) 

:;END OF DEFINITION 
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SCRC:<LMIOB>VFFCTL2,PAL:2 

;.«- nodeiLISP; Pack«Q«:USER; BASEilB -«- 

jPAL ^o*" controlling Oisplau Data Register output enables and the register select 
impute to the An29520*s. Pal appears on dug. VFFCTL 

(DEFPAL VFFCTL2 PAL16L8 

(I PIN 4 TV-On-ACTIVE-A L) .wnT USFD 

CIPIN 5 FILL-ADDR-03) iKoT USED 

(IPIN 6 FlLL-ADDR.e2) '^ ^^^^ 

(I PIN 7 FILL-ADDR-Bl) 

(IPIN 8 f ILL-ADDR-80) 

(IPIN 3 FILL-GO) 

(IPIN 11 OOO-CHUNK-COUNT-A L) ,NOT USED 

(OPIN IS DDR-OE-3 L) 
(OPIN 15 DOR-OE-2 L) 
(OPIN 14 DDR-OE-1 L) 
(OPIN 13 DOR-OE-8 L) 
(OPIN 19 DOR-PIPE-S-1) 
(OPIN 12 DOR-PIPE-S-8) 

(FIELD REG-ADORESS FILL-ADDR-Bl FILL-ADOR-83) 

(SETQ DOR-OE-a (AND FILL-GO (FIELD REG-ADORESS 8))) 

(SETQ DOR-OE-l (AhD FILL-GO (FIELD REG-ADORESS 1)}} 

(SETO DOR-OE-2 (AND FILL-GO IFIELD REG-ADDRESS 2})\ 

(SETQ DDR-0E.3 (AND FILL -GO (FIELD REG-AKIRESS 3H} 

(SETQ DOR-PIPE-S-a (AND FILL-GO (NOT FILL.ADDR-82))) 

(SETQ ODR-PIPE-S-1 (AND FILL-GO FILL.ADDR-82)) 

:;END OF E^FINITION 

SCRC : <LMIOB>VROCTL1 • PAL : 19 

;-»- HodetLISP; PackagexlSER; 6asetl8 -»- 

;PAL for display aeaorg access state aachine 

(DEFPAL VRQCTLl PAL16R4 
;: Inputs 

H£!J1 S JS~?i9y^?L^^ ;Rcque9t for (neinory access on this board 

E K ? ^§-^295;:}^^ rRequest is for video Benorg 

FN 4 LB-UR TE) sRequest Is to write 

(IPIN 5 LB-UAIT) jLbus ts waiting 

(IPIN 6 VD-DONE) (Video tiemory it done 

(IPIN 7 IO-U'RITE-CVtLE> ;.Act,ive cyclS and writing 

(IPIN 8 VD-SSEQ-EWABLE? * ^ a 

(IPIN 9 LB-RESET LI jGeneraf reset (initialize state) 

;; Non-rent stered outpUitff 

(OPIN IS 9D-START L) ?Set VD GO at next clock 

(OPIN IS VD-START-miTE) ;ClocK upite data, close. address latch 

;: Registered output 

(RPIN 14 VO-UAIT C> ;Drive8 LBUS UAIT 

; t State bi t» 

^^PIN 15 VRQ-URITING L) jUrite request in progress 

(RP N 7 VRQ"2AI?n^ \-\ ^K"'**"^ '°: read PeqSest to finieh 

IHKIN 17 VRU-UAITING L) (New request waiting for prev write to finish 

;: Incoming requests 

(SETQ READ-RQ IaND 10-REDUEST LB-ADDR-18 (NOT LB-URITE) (NOT LB-UAIT))) 

(SETQ URITE-RQ (AND iO-REQUEST LB-AOOR-IS LB-URITE (NOT LB^iTi) J 

li^yi^£° '^'oru ts busy tf a write i» in progress and isn't about to finimh 
(SETQ BUSY (AND yRQ-URUim (NOT V0-CO^}T) » • ° '»n i: maoux to rtnien 

;; A write cycle when not busy starts after the data arrive in the active cycle. 
;; The address latch needs to close during the active cycle, in case another 
;; cycle is being requested i timed i ate iy. LBUS UAIT does not coae on. 

;: A read cycle when not busy etartsiimedtately. The address latch closes 
;; during the active cycle. LBUS UAIT stays on until the cycle is conpieted 
:; whereupon we do one last active cycle, giving tine for the data to arrive. 

;; Anu request when busy has to turn on LBUS UAIT and sit In "active cycle" 
:: until the previous request ta completed. GO can then be set iaeediately 
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;; 9n6 •t«ul taneousiy the urfte dita are clocked. 

;; The address latch opens during the last active cycle. 

;; The previous request isn't reallg completed yet when DONE cones in, but 

;; ituill be by the tiae things get through the pipeline to the aemory. 

;; LBUS UAIT is generated while doing a read and when waiting 
;: Note that this bit comes out through a register 
(SETQ VO-WAIT (AND (NOT LB-RESET) 
VD-SSEQ-ENABLE 
(OR REAO-RQ 

(AND VRQ-READING (OR VRQ-UAITING (NOT VO-DONE))) 

(AND URITE-RQ BUSY) 

(AND VRQ-UAITING BUSY)))) 

xhEVa v^5?aj(?flNG"?S5o*7NS?7§i^l^t)^' ''''' ^Q-^^^^^ •*-*• -*'» ^- 

VD-SS£Q-£hiABLE 

(OR (AND READ-RQ BUSY) 

(AND URITE-RQ BUSY) 

(AND VRQ-UAITING BUSY)))) 

:; Enter reading state iainedtately upon READ-RQ 
;; The address latch remains open while reading 
li-Q?"*'"^^* START either immediatefu or after watting for -busy 
(SETQ VRQ-READING (ANO (WOT LB-RESEl> ^ ^ 

VO-SSEQ-ENABLE 
(OR READ-RQ 

(AND VRQ-READING VRQ-UAITING) 
(AND VRQ-READING (NOT VO-OONE))))) 

(SETQ START-FDR-READ (AND (NOT LB-RESET) 

VD-SSEQ-ENABLE 
(OR (AND READ-RQ (NOT BUSY)) 

(AND VRQ-READING VRQ-UAITING (NOT BUSY))))) 

; Enter writin9 state iamediately upon URITE-RQ (it night already be set) 

? Normally go into an active cycle which closes the latch and generates START 

busy first, do this active cycle as soon as DONE 

(NOT LB-RESET) 

VD-SSEQ-ENABLE 
(OR URITE-RQ 

(AND VRQ-URITING VRQ-UAITING) 
it^r-.r. ^^.«^ .-«r. .^,^^ ^AND VRQ-URITING (NOT VD-DDNE))))) 

(SETQ START-FDR-URITE (AND VD-SSEQ-ENABLE 

lO-URITE-CYCLE 
(NOT VRQ-UAITING))) 
(SETQ VD-START (OR START-FOR-READ START-FOR-tffilTE)) 
(SETQ YD-START-URITE START-FOR-URITE) 

: ; end of def ini tion 

SCRC : <LMI0B>VRQCTL2 . PAL ; 13 



, , I f have to wai t for 
(SETQ VRQ-URITING (AND 



:-»- node:LISP; Packaga:USER; Base: 18 -»- 

;PAL for Lbus/vidao control signals 

(DEFPAL VRQCTL2 PALISLS 

Lbus data cycle inputs 
^" VD-READ-LD L) 

VD-READ-HI L) 
LB-ADDR-18-A) 
lO-URITE-CYCLE) 



(iPiN 1 

(IPIN 2 

(IPIN 3 

(IPIN 6 



;Addres8 bit 8 IvaUd in the "active" cycle) 
:Address bit 8_(y3lid in the "data" cycTe) 



;: Oisptau nemoru proc cycle inputs 

(iPIN 7 Dft-ODD-AfiOR) 

(IPIN 8 On-URITE) 

(IPIN 9 VO-GO-SYNC) 

(IPIN 11 VD-PROC-CYCLE L) 

(IPIN 13 VRQ-UAITING L) 

$1 Display Memory control outputs 
(OPIN 14 VD-PRDC-ACTIVE L) 
(OPIN 19 RAS-EN-8) 
(OPIN 12 RAS-EN-l) 

j: 74LS646 control outputs 

(OPIN 15 LB-DATA-URITE.a<-ENB L) 

;; Pin 15 free 

(6pIN 17 LB-DATA<->DnD.LO L) 

(OPIN 18 LB-DATA<.>OnO-Hl LI 

;; Display ■emory controf. RA5 both halves except for single-word 
II processor cycles which RAS one half, and idle processor cycles 
;; which RAS neither. 
(§ETQ VD-PRDC-ACTIVE (AND VO-PROC-CYCXE VD-GO-SYNC)) 



;Addres9 bit 17 (valid in the "active 
;Any URITE cycle on this board 

;Low-order address bit 

•Proc cycle is for write 

;Proc cycle wanted 

;Tiffle for proc cycle 

;in waiting state (see VRQCTLl.PAL) 

;Proc cycle realty happening 
; Enable RAS to even word 
( Enable RAS to odd word 



cycle) 



tenable write clock 

;Output enable for even word 
; Output enabie for odd word 



(SETQ RAS-EN-0 (OR (NOT VO-PRX-CVaE) 

(AND VD-GD-SYNC (NOT On-ODD-ADDR) )) ) 
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(SETQ RAS-EN-1 (OR (NOT VO-PROC -CYCLE) 

(AND VD-GO-SYNC Dfl-OOO-AOOR))) 

;; Output enable is on for telected uord when reading onto Lbus, 

U..5C '/2''^^9^'^ "S'"^' y*^*" processor cycle and writing. 

(SETQ LB-DATA<.>DnD-LO (OR (AND VD-READ-LO (NOT VRQ-QAITING) ) 

(AND VO-PRX-ACTIVE Dn-URITE))) t write cgcles 

(SETQ LB.DATA<->DnD-HI (OR (AND VD-READ-HI (NOT VRQ44AITING}) 

(AND VD-PROC-ACTIVE DH-URITE)}) jwrite cgcles 

(SETQ LB-DATA-URITE.a<-ENB (AND lO-URITE-CYCLE (NOT VRQ^AITING) LB-ADDR-IS-A) ) 

t; end of def ini t ion 

SCRC : <LMIOB>VR0CTL3 . PAL : 3 

t-«- node:LISP; PackagerUSER; Base: 18 -*. 

;PAL for Lbus/video control signals 

;;; OE is grounded, CLK is LB-STATE-CLIC 

(DEFPAL VRQCTL3 PAL1SR4 
: (IPIN 1 LB-STATE-CLK L) 

(IPIN 2 LB.ADDR-0} 

(IPIN 3 LB-ADDR-0-A) 

(IPIN 4 LB-ADDR-IS) 

ilPlN 5 LB-ADDR-IS-A) 

(IPIN 6 LB-ADDR.17) 

(IPIN 7 LB-ADDR-17-A) 

(IPIN 8 lO-READ-RQ) 

(IPIN 9 I O-RE AD-ACTIVE-CYCLE) 

(IPIN 12 lO-URITE-RQ) 

(RPIN 14 VD-READ-HI L) 
(RPIN 15 VD-READ-LO L) 
(RPm 16 SYNC-riEH-CYCLE L) 
(RPIN 17 SYfC-nEH-UE L) 

(SETQ VD-READ-LO (OR (AND jO-READ-RQ LB-ADDR-18 (NOT LB-ADDR-e)) 

(AND IO.REAO-ACTIVE-CYCLE LB-ADOR-IS-A (NOT LB.A0DR-8-A) ))) 

(SETQ VD-REAO-HI (OR (AND lO-READ-RQ LB-ADDR-18 LB-ADDR-0) 

(AND lO-REAO-ACTJVE-CYCLE LB-AD0R-18-A LB-AD0R-8-A) ) ) 

(SETQ SYNC-fTEil-SELECTED (AND LA-ADOR-17 (NOT LB-ADOR-IRDl 
SETQ SYNC-nEn-SELECTED-A mm LB^^nAj-^k mi LB-^^^ 
(SETQ SYNC-n£n-U£ (Ah^ SYTC-r^f^-SELECTED lO-ilmk-RQH ^^^^^^ 

(SETQ SYNC-rtn-CYCLE (OR (AND SYNC-HEri-SELECTEO lO-URITE-RQ) 

J^tiS i53i£-"l"-SELECTED lO-READ-RQ) 

(AND SYNC-HEn-SELECTED-A lO-READ-ACTIVE-CYCLE) ) ) 

s; end of def ini tion 

SCRC : <LMIOB>VR0CTL4 . PAL ; 4 

;-»- f1ode:LISP; PackagerUSER; Base: 18 -«- 

jPAL for Lbus/video control signals. DUG. flEnCTL.DUG 

?;; OE is grounded, CLK is LB-STATE-CL*r 

(DEFPAL VRQCTL3 PAL1GR4 
; (IPIN 1 LB-STATE-CL< L) 

(IPIN 2 LB-ADDR-8) 

(IPIN 3 LB-ADDR-8-A) 

(IPIN 4 LB-ADDR-18) 

(IPIN 5 LB-ADDR-IS-A) 

(IPIN 6 LB-ADDR-17) 

(IPIN 7 LB-ADDR-17-A) 

(IPIN 8 lO-READ-RQ) 

(IPIN 9 ID-READ-ACTIVE-CYCLE) 

(IPIN 12 lO-URITE-RQ) 

(IPIN 13 ID-REQUEST L) 

(RPIN 15 LB-TV-REQ-A L) 
(RPIN IB SYNC-HEn-CYCLE L) 
(RPIN 17 SYNC-riEn-UE L) 

(OPIN 18 LB-TV-REQ L) 

(SETQ LB-TV-REQ (AND lO-REQUEST LB-AODR-18)) 

(SETQ LB-TV-REQ-A LB-TV-REQ) 

(SETQ SYNC-rCn-SELECTED (AND LB-ADOR-17 (NOT LB-ADDR-IS) ) ) 
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(SETQ SYNC-f1En-SELECTED-A (AND LB-ADE«-17-A (NOT LB-ADDR-18-A))) 
(SETQ SYNC-PEn4C fANO SYTC-flEtl-SELECTED lO-URITE-Rai) 

(SETQ-SYNC-nEn-CVCLE (OR (AND |VNC-r|n-||L|CT|g jgl^iolRg?' ^^ _^,„ 

(AND SYNC-nEH-SELECTED-A lO-READ-ACTIVE-CVaE))) 

j; tnd of definition 

SCRC:<LMI0B>VSSEQ.PAL;2 

t-»* node:LISP; Pack«g«:USEH; B«s«:10 -»- 

tPAL For decoding cgci« typts and sync bit«. Aooeari on dug. VCLK. 

(DEFPAL VSSEQ PAL1SR8 

5 ^ii^J.^^^^X^I?^^^"^*^ ^^ tadvancft state only when not uaiting 

(IPIN 2 SD-0) * 

(IPIN 3 SO-l) 

(IPIN 5 SD-8) 

(IPIN S SD-9) 

(IPIN 7 SD-IB) 

(IPIN 8 VO-SREG-ENB) 

(IPIN 9 VD-SSEQ-ENABLE) 

(RPIN 19 BLANIC) 

(RPIN 18 V-SYNC) 

(RPIN 17 H-SYNC) 

(RPIN 16 FRAME -BIT) ;3 

(RPIN 15 TAG-2 L) ;2 

(RPIN 14 TAG-1 L) 1 

(RPIN 13 TAG-0 L) 8 

(RPIN 12 VD-SREG-Era) 

(FIELD CYOE-TYPE SO-l SD-B) 

;; 18«btanK, 9»v eync, 8* h eync 

(SETQ BLANK (AND VO-SSEQ-ENABLE (COND (VD-SREG-ENB SO-10) 

(SETQ V-SVNC (AND VD-SSEQ-ENABLE (COND {rL^g:rNl'iE^ii ^^*'«^'" 

(SETQ H-SVNC (A^O VD-SSEQ-ENABLE (COND UK^lR^EEirNf iE'^ll ^"^^"'^ 

((NOT VD-SREG-ENB) H-SYNC)))) 

(SETQ TAG-0 (FIELD CYCLE-TYPE 0)) 

(SETQ TAG-1 (FIELD CYCLE-TYPE D) 

(SETQ TAG-2 (FIELD CYCLE-TYPE 2)) 

;f1AYBE THE FRAHE BIT SHOULD BE THE SATIE AS ONE OF THE TAGS. 

(SETQ FRAHE-BIT (FIELD CYCLE-TYPE 3)) 

(SETQ YD-SREG-Ef© (OR (NOT VD-SREG-ENB) SO-S))) 

;; end of definition 



SCRC:<LMI0B>XMIT*EIIC.PAL;6 

;-»- node: LISP; Package:US£R; Base:10 -«- 

;;Bi -phase encoder and clock divider for console 

(DEFPAL XniT-ENC PALieR8 
; pin 1 is 9.8304 HHz clock 
(IPIN 2 NR2-TD) 
(IPIN 3 RTSA-LOU) 

(RPIN 19 ENCODEO-TD) 
(RPIN 18 HDLC-RTS) 
(RPIN 17 CLK-153-6<H2) 
(RPIN IB CLIC-307.2KHZ) 
(RPIN 15 CLlC-ei4-4<HZ) 
(RPIN 14 CLIC-l-2288nH2) 
(RPIN 13 a»C-2.457SnHZ) 
(flPIN 12 aiC-4-9152nHZ) 



(SETQ aiC32 CLK-153-6KHZ ) 

(SETQ aiCie CLK-307-2KHZ ) 

(SETQ a»C8 CLIC-S14-4KHZ ) 

(SETQ aK4 CL»C-l-2288nHZ) 



CSETQ aJC2 
(SETQ a< 
(SETQ PULSE 
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CLK-2-4576nHZ) 
CLk:-4-9152nH2) 
(AND (NOT CLK) 
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(NOT €LK2} a<4)) 



(SETQ ENCOOED-TO 
(SETQ HXC-RTS 



(XOR ENCODED-TO (AKD PULSE (OR aK8 (NOT NRZ-TD) ) ) ) ) 
(COND ((AND CLK8 PLfLSE) RTSA-LOU) 

((NOT (AND CLK8 PULSE)) HOLC-RTS))) 



(SETQ aiC32 

(SETQ CLKIG 
(SETQ a<s 
(SETQ CLKU 
(SETQ CL<2 

(SETQ ax 



(XOR CLK:32 (NOT 

(XOR CLK16 (NOT 

(XOR CLK8 (NOT 

(XOR CL<4 (NOT 



(XOR CL<2 
(NOT CLK)) 



(OR cue CLIC2 CLIC4 CL<8 CLKIS)))) 
(OR CL< CL<2 CL<4 CLK8)))) 
(OR CL< CLK2 CLK4)))) 
(OR CL< CLK2)))) 



(NOT CLO)) 



of def ini lion 



SCRC : <LFEP>UDMAHA . PAL ; 2 



FEP - PAL 



;;; -«. Hode: LISP; Base: 18; Package: USER -»- 

(DEFPAL UDHAHA PAL1BL8 
(OPIN 12 UR-HIGH-ADR L) 
(OPIN 19 RD-HIGH-ADR L) 
(OPIN 13 CTL-UR L) 
(OPIN 14 CTL-RD L) 
(OPIN 15 DEV-e L) 
(OPIN IB DEV-1 L) 
(OPIN 17 DEV-2 L) 
(OPIN 18 DEV.3 L) 



(IPIN 1 
(IPIN 2 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 8 
(IPIN S 
(IPIN 11 



CTL-RQ L) 
Al H) 
A8 H) 

CART-DACK H) 
PAR-DACK H) 
SERB-DAC< H) 
SERA-OACK H) 
I ORG H) 

HIGH-ADR-RQ L) 
UR1TE-T258 H) 



(SETQ DEV.3 (OR (AND HIGH-ADR-RQ Al A8) CART-DACO ) 

(SETQ DEV.2 (OR (AND HIGH-ADR-RQ Al (NOT A8) ) PAR-DACO ) 

(SETQ DEV-1 (OR (AND HIGH-ADR-RQ (NOT Al) A8) SERB-DACK)) 

(SETQ DEV.8 (OR (AND HIGH-ADR-RQ (NOT Al) (NOT A8) ) SERA-DACK)) 

(SETQ CTL-RD (AND lORC CTL-RQ)) 
(SETQ CTL-UR (AND URITE-T258 CTL-RQ)) 



(SETQ RD-HIGH-ADR 
(SETQ UR-HIGH-ADR 



(AND lORC HIGH-ADR-RQ)) 

(AND URITE-T258 HIGH-AOR-RQ))) 



SCRC : <LFEP>UDMABC • PAL ; 3 



;;; -«- Mode: LISP; Base: IB; Package: USER -»- 

(DEFPAL UOnABC PAL16L8 
(OPIN 12 URITE-REG H) 
(OPIN 19 REAO-REG H) 
(OPIN 13 lORC L) 
(OPIN 14 lOUC L) 
(OPIN 15 riRDC L) 
(OPIN 16 nUTC L) 
(OPIN 17 CLEAR-READY H) 



(IPIN 18 



(IPIN 

(IPIN 

(IPIN 

(IPIN 

(IPIN 

(IPIN 

(IPIN 

(IPIN 8 

(IPIN 9 

(IPIN 11 



BG L) 
I OR L) 
lOU L) 
ID-SPACE H) 
riEHR L) 
riEm L) 
T2B8 H) 
T58 H) 
BUS-IOUC H) 
BUS-IORC H) 
RQ L) 



(SETQ URITE-REG (AND BUS-IOUC RQ (NOT T2e8))) 
(SETQ READ-REG (AND BUS-IORC RQ T58) ) 



(SETQ lORC (AND BG 

(SETQ I Due (AND BG 

(SETQ HRDC (AND BG 

(SETQ nUTC (AND BG 



lO-SPACE riEMR)) 
ID-SPACE nEHU)) 
(NOT lO-SPACE) flEnR)} 
(NOT lO-SPACE) HErtU)) 



(SETQ CLEAR-READY (AND BG (OR reiR lOR)))) 
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SCRC:<LFEP>SERIAB.PAL;2 
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;;; -«- ttode: LISP: Base: 18; Package: USER -«- 

(DEFPAL SERIAB PAL1BL8 
<OPIN 12 TX-CLK-0 H) 
(OPIN 19 RX-CLK-0 H) 
(OPIN 13 TX-CK-2 H) 
(OPIN 14 RX-CU-2 H) 
(OPIN 18 BAUD-UR H) 

(IPIN 1 URITE-T2Ba L) 

(IPIN 2 BAUD-RQ L) 

(IPIN 3 GEN-BAUD-2 H) 

(IPIN 4 EXT-RX.CLX;-2 H) 

(IPIN 5 EXT-TX-CU-2 H) 

(IPIN 6 CU-SEL-2 H) 

(IPIN 7 GEN-BAUD-8 H) 

(IPIN 8 EXT-RX-CLK-e H) 

(IPIN 9 EXT-TX-CLK-8 H) 

(IPIN 11 CU-SEL-8 H) 

(SETQ BAUD-UR (AND BAUO-RQ IJRITE-T258)) 

(SETQ RX-CLIC.8 EXT-RX-aiC-8) 
(SETQ TX-CLIC-a EXT-TX-CU.0} 



(SETQ RX-CL<-2 (COND 
(SETQ TX-(XK-2 (COND 



((NOT CK-SEL-8) GEN-BAUO-8) 
(CLK-SEL.8 EXT-RX-CLK-2))) 
((NOT a<-S£L-2) GEN.SAUD-2) 
(CLIC-SEL-2 EXT-TX-a<-2U>> 



SCRC:<LFEP>SERDMA,PAL;8 

;•: -«* node: LISP; Base: 10; Package: USER -«- 

(DEFPAL SERDHA PAL16L8 
(OPIN 12 SERA-DREQ H) 
(OPIN 19 SERB-DREO H) 
(OPIN IS DflA-CYCLE L) 
(OPIN 17 DnA-R/-U H) 
(OPIN 18 DHA-SEL-AZ-B 



H) 



(IPIN 14 
(IPIN 13 



(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 



(IPIN 11 



SERB-RXRQ H) 
SERB-TXRQ H) 
SERA-RXRQ H) 
SERA-TXRQ H) 
DHA-Bl H) 
DnA-B0 H) 
DHA-Al H) 
DnA-A0 H) 
SERB-DACK H) 
SERA-DACK H) 
lOU L) 
lOR L) 



(SETQ SERA-OREQ (COND ((AND (NOT DHA-Al) (NOT DnA-A8) ) SERA-TXRQ) 
((AND (NOT DMA-Al) DHA-Aa) SERA-RXRQ) 
((AND DHA-Al (NOT DnA-A0) ) SERB-TXRQ) 
'((AND DHA-Al DnA-A0) SERB-RXRQ))) 

(SETQ SERB-DREQ (COND ((AND (NOT DMA-Bl) (NOT Df1A-B0)) SERA-TXRQ) 
((AND (NOT DHA-Bl) DnA-B0) SERA-RXRQ) 
((AND DnA-Bl (NOT DnA-B0)) SERB-TXRQ) 
((AND DflA-Bl DflA-BB) SERB-RXRa))) 

(SETQ OriA-CYCLE (AND (OR SERA-DACiC SER8-DACK) (OR lOU lOR))) 
(SETQ OnA-R/-U lOR) 
(SETQ OHA-SEL-AZ-B (OR 



(AND SERA-DACK 
(AND 5£RB-DAC< 



(NOT OHA-AD) 
(NOT DHA-Bl))))) 



SCRC:<LFEP>SERCTL.PAL:4 



;;; -«- flode: LISP; Bate: 10; Package: USER -«- 

(DEFPAL SERCTL PAL1BL8 
(OPIN 17 DRIVE-BUS H) 
(OPIN IB SERIAL-Al H) 
(OPIN 15 SERIAL-A0 H) 
(OPIN 14 B-CS L) 
(OPIN 13 A-CS L) 
(OPIN 19 UR L) 
(OPIN 12 RD L) 

(IPIN 1 T300 H) 

(IPIN 2 OriA-SEL-AZ-B H) 

(IPIN 3 OnA-RZ-U H) 

(IPIN 4 DHA-CYCLE L) 
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(IPIN 


5 


lOUC H) 


(IPIN 


G 


lORC H) 


(IPIN 


7 SERIAL-RQ L) 


(IPIN 




A2 H) 


(IP^N 


9 


Al H) 


(IPIN 11 


A0 H) 



(SETQ RD (OR (AND SERIAL-RQ lORC) 

(AND DMA-CYCLE DflA-RZ-U))) 
(SETQ UR (OR (AND SERIAL-RQ lOUC (NOT T303) ) 

lerrn n«rwrr ^.l^^Sr^P^^-^^t^ ^^^ DTIA-RZ-U) ) } } 

(SETQ DRIVE-BUS RD) 

(SETQ A-CS (OR (AND SERIAL-RQ (NOT A2)) 

,^, (AND DHA-CYCLE DnA-SEL-AZ-BH ) 

(SETQ B-CS (OR (AND SERlAL-RQ A2} 

(AND DHA-CYCLE (NOT Om-SEL-A/^) ) ) > 

(SETQ SERIAL-A0 (OR (AND SERIAL-RQ A0) 

tAND DriA-CYCLE NIL))) 
(SETQ SERIAL-Al (OR (AND SERIAL-RQ Al) 

(AND DnA-CYCLE NIL)))) 
SCRC:<LFEP>RE0SEL.PAL:28 

;;; -«- ftede: LISP; Base: 18; Package: USER -«- 

(DEFPAL REQSEL PAL1GL8 
(OPIN 12 LOU-BYTE L) 
(OPIN 19 HIGH-BYTE L) 
(OPIN 18 ROn-RQ L) 
(OPIN 17 RAn-RQ L) 
(OPIN 16 LDHA-RQ L) 
\^W }5 HIGH-TO-LOU-BYTE L) 
(OPIN 14 LOU-TO-HIGH-BYTE L) 

(IPIN 13 nUTC H) 
(IPIN 1 lOUC H) 
(IPIN 2 nRDC H) 
(IPIN 3 lORC H) 
(IPIN 4 BUS-nASTER L) 
CIPIN 5 BHEN H) 
(IPIN 6 A19 H) 
(IPIN 7 A18 H) 
(IPIN 8 A17 H) 
(IPIN 9 A16 H) 
(IPIN 11 A0 H) 

(FIELD 64K.NUn8ER A19 A18 A17) 

(^rg LOU-BYTE (OR BHEN (NOT A0) ) ) 
(SETQ HIGH-BYTE (OR BHEN A0)) 

(SETQ HIGH-TD-LOU-BYTE (OR (AMD BUS-HASTER (NOT BHEN) (NOT A0) 

(FIELD 64>; -NUMBER 2) 
^ (FIELD 64K-NUnBER 3)) 

(SETQ LOU-TO-HIGH-BYTE (OR (AND BUS-flASTER InOt'bHEN) (NOT A8) 

'*^ '^ ElS°||°N§^^iR^^^ «' '^' *^^>> 
(FIELD G4K-NUnBER 2) 
(FIELD 64IC-NUnBER 3)) 

(SETD ROn-RQ (AND (FIELD SAK-NUnSER e?"^NOT*Aie)l^nRDC) ) 
iiISf^:''9„'AND (FIELD BAK-NUnBER 1 OR ORDC nUTC) 
(SETQ LDHA-RQ (AND (OR (FIELD GAK-NUnBER 2) (FIELD SAK-NUHBER 3)) 
lOR nRDC nUTC)))) 

SCRC:<LFEP>PR0CA,PAL;8 

:-»- node;LISP; PackagerUSER; Base:10 .»- 

;;: fluitibus Arbitrator Microcode 

(COmENT 

;;; Tiding based upon ISmhz clock 

((ext-rq udma-rq bus-grant bua-free state) next-state ...) 

r/i o°°P here granting the BS000, waiting for another request 
1(0 8 X X 0) fcp-grant) 

•iV t^^Jl®'*^? "^""^ ^^^ ^^^ ^o'" the bus from the B8000 
((x 1 X 0) fcp-grant bus-rq) 

Vy r°} «^2*^ii' ^^^^ *^® SS000, uait for the current bus cycle to complete 

((x 1 1 0) fep-grant bus-rq) ^ 

••? I* completed, ack the 68030 grant, and grant udma 

l(x 1 1 1 0) 1 udraa-grant bus-rq bus-grant-ack) 
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;;: Uaft uhTfe the udma uses the bus 

({x X K 9 1) 1 udma-gpant bus-grant-ack) 

;:; The bus has become free, uait until the udma gives up its request 

((x 1 X 1 1) 1 udma-grant bus-grant-ack) 

;;t-If ext is peqL^ssting, then grant it 

((1 X 1 1) 2 ext-grant bus-grant-ack.> 

;:t Otherwise. let the 6S8S8 run aofie wore 

((a X 1 1) fep-grant) 

;;: Here's Bn ext rq. Ask for the bus froa the BS000 

{(1 X 0) fep-grant bus-rq) 

;;: Got the bus from the &S000. uait for the current bus cycle to complete 

((10100) fep-grant bus-rq) 

;;: It compteted, ack the 68000 grant, and grant ext 

((1 1 1 0) 2 ext-grant bus-rq bus-grant-ack) 

:;; Uait uhile ext uses the bus 

((x X X 2) 2 ext-grant bus-grant-ack) 

;:: The bus has become free, uait until the ext gives up its request 

((1 X X 1 2) 2 ext-grant bus-grant-ack) 

;;: If udma is requesting, then grant it 

((01x12) 1 udma-grant bus-grant-ack) 

:;: Othsrutse, let the 68080 run some more 

((0 X 1 2) fep-grant) 

) ;£nd COnriENT 

;;: Logic aquations for PAL compiler 

(defpal PROCA PALISRS 
;; Inputs 

(iPIN 3 BUS-GRANT L) 
(I PIN 6 BUS-FREE H) 
(IPIN 4 EXT-BR L) 
(IPIN 2 UDMA-BR H) 

(RPIN 12 STATE.0 L) 
(RPIN 13 STATE-1 L) 
(RPIN 14 STATE-2 L) 
(RPIN 15 BGACJC L) 
(RPIN IS BR L) 
(RPIN 17 FEP-BG L) 
(RPIN 18 EXT-BG L) 
(RPIN 19 UDHA-BG L) 

(FIELD STATE STATE-2 STATE-l STATE-0) 

(SETQ UDHA-BG (OR (AND UDMA-BR BUS-GRANT BUS-FREE (FIELD STATE 0)) 
(AND (NOT BUS-FREE) (FIELD STATE D) 
(AND UDMA-BR BUS-FREE (FIELD STATE D) 
(AND (NOT EXT-BR) UDMA-BR BUS-FREE (FIELD STATE 2)))) 
(SETQ EXT-BG (OR (AND EXT-BR (NOT UDMA-BR) BUS-FREE (FIELD STATE D) 

(AND EXT-BR (NOT UDMA-BR) BUS-GRANT BUS-FREE (FIELD STATE 0)) 
(AND (NOT BUS-FREE) LFIELD STATE 21) 
(AND EXT-BR BUS-FREE (FIELD STATE 2)))) 
(SETQ FEP-BG (OR (AND (NOT EXT-BR) (NOT UDnA-BR\ (FIELD STATE 0>) 
(AND UDMA-BR (NOT BUS-GRANT) (FIELD STATE 0)) 
(AND UDMA-BR BUS-GRANT (NOT BUS-FREE) (FIELD STATE 0)) 
(AND (NOT EXT-BR) (NOT UDMA-BR) BUS-FREE (FIELD STATE D) 
(AND EXT-BR (NOT UDMA-BR) (NOT BUS-GRANT) (FIELD STATE 0)) 
(AND EXT-BR (NOT UDMA-BR) BUS-GRANT (NOT BUS-FREE) (FIELD STATE 0)) 
(AND (NOT EXT-BR) (NOT UDMA-BR) BUS-FREE (FIELD STATE 2)))) 
(SETQ BR (OR (AND UDMA-BR (NOT BUS-GRANT) (FIELD STATE 0)) 

(AND UDMA-BR BUS-GRANT (NOT BUS-FREE) (FIELD STATE 0)) 
(AND UDMA-BR BUS-GRANT BUS-FREE (FIELD STATE 8>) 
(AND EXT-BR (NOT UDMA-BR? (NOT BUS-GRAt^T) IFIELD STATE 0)) 
(AND EXT-BR (NOT UDMA-BR) BUS-GRAWT (NOT BUS-FREE) (FIELD STATE 0)) 
(AND EXT-BR (NOT UDMA-BR) BUS-GRANT BUS-FREE (FIELD STATE 0)))) 
(SETQ BGACK (OR (AND UDMA-BR BUS-GRANT BUS-FREE (FIELD STATE 0)) 
(AND (NOT BUS-FREE) (FIELD STATE D) 
(AND UDMA-BR BUS-FREE (FIELD STATE D) 
(AND EXT-BR (NOT UDMA-BR) BUS-FREE (FIELD STATE D) 
(AND EXT-BR (NOT UDMA-BR) BUS-GRANT BUS-FREE (FIELD STATE 0)) 
(AND (NOT BUS-FREE) (FIELD STATE 2)) 
(AND EXT-BR BUS-FREE (FIELD STATE 2)) 
(AND (NOT EXT-BR) UDMA-BR BUS-FREE (FIELD STATE 2)))) 
(SETQ STATE-0 (OR (AND UDMA-BR BUS-GRANT BUS-FREE (FIELD STATE 0)) 
(AND (NOT BUS-FREE) (FIELD STATE D) 
(AND UDMA-BR BUS-FREE (FIELD STATE D) 
(AND (NOT EXT-BR) UDMA-BR BUS-FREE (FIELD STATE 2)))) 
(SETQ STATE-l (OR (AND EXT-BR (NOT UDMA-BR) BUS-FREE (FIELD STATE D) 

(AND EXT-BR (NOT UDMA-BR) BUS-GRANT BUS-FREE (FIELD STATE 0)) 
(AND (NOT BUS-FREE) (FIELD STATE 2)) 
(AND EXT-BR BUS-FREE (FIELD STATE 2)))) 
(SETQ STATE-2 NIL)) 
SCRC : <LFEP>FROC • PAL ; 4 

t-«- node:LISP; Package:U5ER; Base:10 -»- 

(defpal PROG PAL1SL8 
(IPIN 11 LDS L) 
(IPIN 9 UDS L) 
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(IPIN 


8 


AS L) 


(IPIN 


7 fCB H) 


(IPIN 


6 


FCl H) 


(IPIN 


5 


FC2 H) 


(IPIN 


4 


URITE L) 


(IPIN 


3 


lO-SPACE L) 


(OPIN 12 


ODD-BYTE H) 


(OPIN 19 BHEN H) 


(OPIN 


13 


AUTOVECTOR L) 


(OPIN 


14 


lOUC L) 


(OPIN 15 


I ORG L) 


(OPIN 


16 


nUTC L) 


(OPIN 


17 


riRDC L) 


(OPIN 18 ANY-RQ L) 



:: Bute and uord control tignals 
(SETQ OOD-BYTE (AND (NOT UOS) LOS)) 
(SETQ BHEN (AND UOS LOS) ) 

^(k?Q"AU^0V^?TOR'lIN^°^^^^^ ?^^°Xi?j''^'« ""P""''"' "P°" P^'°^**« ^•^•' 

;: Decode the four Kinds of bus commands 

(SETQ iguC (AND URITE lO-SPACE AS (OR UDS LDS) (NOT AUTOVECTOR))) 

/£ E \Z ^TrE^'^^lVih^^^d if {8g Ijgi hill f S 

(SETQ ANY-fiQ (AND AS (OR UOS LDS) (NOT AUTOVECT OR))) ) 
SCRC:<LFEP>PAGTAG.PAL;5 

; -«- Modes Lisp; Package: User; Basetia -«- 
; PAL for phgsical page tag neiiiory 
(OEPPAL PAGTAG PAL1EL8 

wriry i, riuu-^J <Ev«n nari+n 

PINipT^I:-^! |PagS£o5i^yed 

tlPIN 3 PTOL-8) .not GC tag 

(iPin'ORITE?^^firL)"'°"'''°''''"'*^ 

(IPIN 5 DP-SET-GC-TAG L) 

(IPIN 13 NORflAL-ACTJVE L) 

Up?N"rLBUS-6Ev!4)°'' "'c^c^code-drrected operation 

(IPIN 9 LBUS-DEvIs) 

(IPIN 11 URITE-PAGE-TAG L) 

;: Bank-select bits 

(tPIN 6 PT-PAGE-15) 

(IPIN 7 PT-PAGE-0) 

'(6P?N*f9*PTl!l?' "^***'" *"*^ P«B« *»9 ""o^W <paritg computed externang) 
(OPIN 12 PTI-0) 
lA^?S"^Z"'«ct outputs 
OPIN 15 PAGE-TAG-EN-I L) 
(OPIN 16 PAGE-TAG.EN-0 L) 
V^9m*PV^2J? C®2* °^ machine 

;pin 14 is a spare 

;; Bank selection 

(SETQ PAGE-TAG-EN-0 (AND (NOT PT-PAGE-0) (MOT PT-Papf icmi 

(SETQ PAGE-TAG-EN-1 (/W PT^i^AGE:© (NOT PT^A^^ 

;: Parity checking 

(SETQ PAGE-TAG-PAR-ERR (AND (NOT PT-PAGE-15) 

(FIELD PTOL-2 PTOL-1 PTOL.0 (12 4 7)))) 

»i^l£5i*nS of addressed bit (garbage if PT-PAGE-15 ia 1) 

(SeTQ PAgI-TAG-COND (CONO ((pflLD !bUS:DEV-4 LBUSlDEV-S 8) (NOT PTOL-8)) 

F ELD LBUS-DEV-4 LBUS-DEV-3 1 PTOL-1 

((FIELD LBUS-DEV-4 LBUS-DEV-3 2 PTOL-2 

((FIELD LBUS-DEV-4 LBUS-DEV-3 3) NIL))) 

\^l^ H5il|-i?r^^^.^*'*' "RITE-PAGE-TAG (NOT LBUS-DEV-4))) 
(SETQ URITE-REF-TAG (AND UR/TE-PAGE-TAG LBUS-DEV-4)) 

iJ..-yj;',ii?9,°LS3g« peferenced bit 

(SETQ PTI-1 (Oft lAND URITE-REF-TAG LBUS-DEV-3) -riicrocod^ ««t« „^ ^. , 

NORriAL-ACTlVE))) • ^^5* referenced 

Ue'^5'^I?28''In§? 188 ?;,5D'5^?^Tl?Ge!7gi'ri(]|!gEV^:^!,*° 'flii<!;o'^o*d':'.%"?i ». Cear. 
(AND (NOI URITE-GC-TAG) (NOT PTOLI?)) °"?Hold SthSrSiSr 
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(AND war URfTE-GC-TACr :Set ff page written 

HglJErACTIVE . and value written is a 



SCRC:<LFEP>LBPAR.PAL;9 

::: -*- node:LI5P; Package:USER; BaseilS -»> 
;:: Paritg generate, rae enables 



(OEFPAL LBPAR PAL1SL8 


UPIN 


15 HB-BUS H) 


(IPIN 


IG LB-BUS H) 


(IPIN 


11 HB-PAR-ODD H) 


(IPIN 


9 LB-PAR-OOO H) 


(IPIN 


8 U-UE L) 


(IPIN 


7 U-CE L) 


(IPIN 


6 NEE0-L8US L) 


(IPIN 


5 A8 H) 


(IPIN 


A BHEN H) 


(IPIN 


3 u-ns-CE H) 


(OPIN 12 HB-CE L) 


(OPIN 


13 LB-CE L) 


(OPIN 


13 HB-WE-ENB L) 


iOPlH 


14 LB-UE-ENB L) 


(OPIN 


15 HB-BUS-OUT H) 


(OPIN 


IS LB-BUS-OUT H) 


(OPIN 


17 HB-PAR H) 


(OE 


17 HB-PAR-ENB) 


(OPIN 


18 LB-PAR H) 


(OE 


18 LB-PAR-ENB) 



(SETQ HB-BUS-OUT (OR BHEN A8) ) 
(SETQ LB-BUS-OUT (OR BHEN (NOT A8) ) } 

xii Parity generation and enables 

(SETQ HB-PAR-ENB U-UE) 

(SETQ LB-PAR-ENB U-UE) 

(SETQ HB-PAR (NOT HB-PAR-ODO)) 

(SETQ LB-PAR (NOT LB-PAR-ODO)) 

;:: Enables 

(SETQ HB-UE-ENB (AND U4JE (OR NEEO-LBUS HB-BUS))) 

(SETQ LB-UE-ENB (AND U-i£ (OR NEEO-LBUS LB-BUS))) 

(SETQ HB-CE (CDND (U-HB-CE (NOT HB-BUS)) 

(•(NOT U-riB-CE) (AND U-CE (OR NEED-LBUS HB-BUS))))) 

(SETQ LB-CE (COND (U-flB-CE (NOT LB-BUS)) o^on u > 

((NOT U-HB-CE) (AND U-CE (OR NEED-LBUS LB-BUS))))) 



SCRC:<LFEP>LBBD.PAL;6 

;;; -»- l1ode:LI5P; Package:U5ER; Base:ld -»- 
;;; Buf to bus control, parity enables 



(OEFPAL 


LBBD PAL1SL8 


(IPIN 


11 A0 H) 


(IPIN 


3 BHEN H) 


(IPIN 


8 BUS-TO-RAH H) 


(IPIN 


7 NEED-LBUS L) 


(IPIN 


6 riRDC H) 


(IPIN 


5 ANY-RQ-RAU H) 


(IPIN 


4 I ORG H) 


; (IPIN 


3 BOARD-ID-RQ L) 


(IPIN 


2 riB-CONTROLLED-CE H) 



t Unused — should be NC 



(OPIN 12 HB-XCVR-OE L) 
(OPIN 19 LB-XCVR-OE L) 
(OPIN 15 XCVR-READ H) 
(OPIN IS PAR-HB-ENB H) 
(OPIN 17 PAR-LB-ENB H) 

;; Parity control* 



;; Though this enables spuriously when writing Into the raas during a NEED-LBUS 
;: type read cycle, it doesn't watter, since th 



he registers aren't getting clocked* 



Not checking in the BUS-TO-RAfI case fixes the probiei« where you clock the registers 
ii during a NEEO-LBUS write cycle to get the low order 8 or IB bits. 
(§£TQ PAR-HB-ENB (OR (AND XCVR-REAO (OR BHEN A8) ) 

(AND NEED-LBUS (NOT ttB-CONTROLLED-CE)) 

(AND nS-CONTROLLED-CE (NOT (OR BHEN AB))))) 
(SETQ PAR-LB-ENB (OR (AND XCVR-REAO (OR BHEN (NOT A8) ) ) 

(AND NEED-LBUS (NOT m-CONTRDLL£D-CE) ) 

(AND ne-CONTROLLEO-CE (NOT (OR BHEN (NOT A8)))))) 



4,887,235 
1203 

;; Bus transceiver control 

(^ETQ XCVR-READ MRDC) 

(SETQ HB-XCVR-OE (AND ANY-RQ-RAU (OR BHEN AB) 

(OR (AND (NOT XCVR-READ) BUS-TO-RAn) 
XCVR-REAO))) 
iSETQ LB-XCVR-OE (AND ANY-RQ-RAU (OR BHEN (NOT AB) ) 

(OR (AND (NOT XCVR-REAO) BUS-TO-RAn) 
XCVR-READ)})) 



1204 



SCRC:<LFEP>LBARB.PAL:1 

;-»- flodctLISP; PacKagerUSER; BasezlB -«- 

;Lbu« arbitrator and eye I a control PAL for FEP 

(DEFPAL LBARB PAL1SL8 

(IPIN 11 REFRESH-RQ L) 

(IPIN 9 FEP-LBUS-RQ L) 

(IPIN 8 BUS-nUTC) 

(IPIN 7 ANY-ACTIVE L) 

(IPIN G FEP-LBUS-ACTIVE L) 

(IPIN 5 FEP-LBUS-DATA-CYC L) 

(IPIN 4 FEP-LBUS-ID-REQ L) 

(IPIN 3 FEP-LBUS-ECC-DIAG) 

(OPIN 12 FEP-LBUS-REFRESH L) 
(OP IN 19 FEP-LBUS-GRANT L) 
(OPIN 13 FEP-LBU5-URITE L) 
(OPIN 14 FEP-LBUS-DR I VE-ECC L) 
(OPIN 15 FEP-LBUS-DR I VE-DATA L) 
.(OPIN 16 FEP-LBUS-LATCH-OPEN) 
(OPIN 17 FEP-LBUS-DRIVE-ADR L) 
(OPIN 18 FEP-LBUS-DR I VE-ADR-AND- ID L) 

;; FEP and Refresh request arbitration 

;; Refresh has hiahest priority, FEP has second-highest, Proc & IFU louest 

(SeTQ FEP-LBUS-REFRESH TaND REFAeSH-RQ (NOT ANY-ACTIVE) 5) 

{SETQ FEP-LBUS-GRANT (Af© (NOT REFRESH-RQ) (NOT ANY-ACTIYE) ) ) 

(SETQ URITE BUS-HUTC) 

(SETQ FEP-LBUS-URITE (AND FEP-LBUS-GRANT URITE)) 

j; FEP Lbus addresa/data transcBl^er control 

;: Drive the Lbus data lines during active' urite cucle 

(SETQ FEP-LBUS-DRIVE-DATA (AND FEP-LBUS-ACTIVE URITE)) 

(SETQ FEP-LBUS-DR I VE-ECC (AND FEP-LBUS-DRIVE-DATA FEP-LBUS-ECC-DIAG)) 

\kTQ'FEpfLBUs!LA^^^^ FE^-^BUS-ID^^EQ*'' *"' '''^ '"^'"' '''' ^y^"* °^ * ^"^ 

„ . (AND FEP-LBUS-DATA-CYC READ))) 

lk?QVlp!^g[;S^*5R?v1::Ae5'?^^ ^° ^^^* °^ ^^^^"^ "^- »*^ requesting 

(SETQ FEP-LBUS-DRIVE-AOR-AND-ID (OR FEP-LBUS-ID-REQ FEP-LBUS-GRANT))) 



SCRC:<LFEP>LBAAR.PAL;4 



-«- ModerLISP; Pac*cagerUS£R; Ba«e;10 -«- 



(DEFPAL LBAAR PAL1BL8 


(IPIN 


11 


A0 H) 


(IPIN 


9 


Al H) 


(IPIN 


8 


A2 H) 


(IPIN 


7 


U-SEL-A0 H) 


(IPIN 


6 


U-SEL-Al H) 


(IPIN 


5 BHEN H) 


(IPIN 


4 


U-RUN-LBUS H) 


: (IPIN 


3 


BOARD-ID-RQ L) 


(IPIN 


2 


nUTC H) 


(IPIN 


1 


ANY-RQ-SYNC H) 


(IPIN 


14 


NEED-LBUS L) 


(IPIN 


16 


LDflA-RQ L) 


(IPIN 


17 


BUF-SEL H) 


; (IPIN 


18 


LBUS-ID L) 


(OPIN 


12 BUF-A0 H) 


(OPIN 


19 


BUF-Al H) 


(OPIN 


14 


NEED-LBUS-OUT L) 


(OPIN 


15 


ANY-RQ-RAU H) 



; Unused — should be NC 



(Unused — should be NC 



(SETQ NEED-LBUS-OUT (OR U-RUN-LBUS 

(AND (NOT BUF-SEL) LDHA-RQ HUTC Al (OR BHEN A0) ) 

(AND (NOT BUF-SEL) LDTIA-RQ (NOT MUTC) (NOT Al) (OR BHEN (NOT A0))))) 
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Uhen needing the LBUS, )ou tuo %dr bfts cone fron ucode 
Uhen not needing the LBUS. low adr bit co»ea from Al on flultjbue, end 
_ next adr bit comes from A2 if hackmg the buffer directty, or ie forced 
to one if in "LBUS space", eo that the iou order bit selects between the lou 
; and nediun uords 
SETQ BIF-A8 (OR (AND f£ED-LBUS U-SEL-AB) 

(AND (NOT NEED-LBUS) Al))) 
(SETQ BUF-Al (OR (AND NEED-LBUS U-SEL-Al) 

(AND BUF-SEL (NOT NEED-LBUS) A2) 
(AND (NOT BUF-SEL) (NOT NEED-LBUS)))) 

(SETQ ANY-RQ-RAU (AND ANY-RQ-SYNC LOflA-RQ) ) ) 

;-«- rioderLISP; Package: USER; BasetlS -»- 

t;; Addreeees: control (350), data (3S2), pointer (354) 
(defpat HSRQ PAL1BL8 

(IPIN 11 Al H) 

(IPIN 9 A2 H) 

(IPIN 8 lOUC H) 

(IPIN 7 BUF-RQ L) 

(IPIN 6 TSe H) 

(IPIN 5 DTIA-SYNC^ L) 

(IPIN 4 URITE-TO-DEV H) 

(IPIN 3 T289 H) 

(IPIN 2 BUF-ACK-URITE H) 

(OPIN 12 OO-URITE" L) 
(OPIN 19 OUT-ENB L) 
(OPIN 13 URITE-ADR L) 
(OPIN 14 READ-ADR L) 
(OPIN 15 URITE-CTL L) 
(OPIN IB READ-CTL L) 
(OPIN 17 OATA-RQ L) 
(OPIN 18 ACIC L) 

;; Start buffer aeMorg write if either reading from the device and got a eunc pulse, 
;: or if the processor does a write cycle to the buffer 
(SETQ DO-URITE^ (OR (AND (NOT URITE-TO-DEV) OnA-SYNC") 

(AND (NOT A2} Al BUF-RQ (NOT T59) lOUC))) 
;; Enable buffer RAfIs to drive if writing to the device and no processor request, 
;; or a processor read request 
(SETQ OUT-ENB (OR (AND URITE-TO-DEV (NOT BUF-RQ)) 

(AND BUF-RQ (NOT lOUC)))) 
;; Address and cycle- type decoding 
(SETQ URITE-AOR "aNO BOF-RQ JOUC A2 (NOT Al))) 
(SETQ READ-ADR (AND BUF-RQ (NOT I DUO A2 (NOT Al))) 
(SETQ URITE-CTL (AND BUF-RQ lOUC (NOT A2) (NOT Al))) 
(SETQ READ-CTL (AND BUF-RQ (NOT lOUC) (NOT A2) (NOT Al))) 
(SETQ DATA-RQ (AND BUF-RQ (NOT A2) AD) 
:; Ack processor request 
(SETQ ACK (OR ;: AcK for pointer cycles 

(AND BUF-RQ A2 (NOT Al) T209) 



M' 



Ack for control cycles 
^ BUF-RQ (NOT A2) (NOT Al) T208) 
;; Ack for data read cycles 
(AND BUF-RQ (NOT A2) Al (NOT lOUC) T280) 
;; Ack for data write cycles 
(AND BUF-RQ (NOT A2} Al I OX BUF-ACIC-URITE) ) )) 



SCRC:<LFEP>HSA0R.PAL:9 

;;; -«- flode: LISP; Package: USER; Base: 10 -»- 

;;; PAL for control of high speed buffer address 

(defpal HSAOR PAL16R4 
:: Inputs 

(iPIN 9 URITE-T50 L) 
(IPIN 8 BUS-DATA-RQ L) 
(IPIN 7 SPY-DHA-SYNC L) 
(IPIN 6 URITE-AOR L) 
(IPIN 5 COUNT-UP H) 
(IPIN 4 SPY-DHA-ENB H) 
(IPIN 3 BUS-READ H) 
(IPIN 2 BUS-D0 H) 

;x Outputs 

(OPIN 19 ENB-HIGH-BITS-COUNT L) 

(OPIN 18 ADR-CL< L) 

(OPIN 13 SPY-DHA-ENB-LB L) 

(OPIN 12 SPY-DflA-ENB-HB L) 

(RPIN 17 BUF-A0 H) 
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(SETQ EfB-HIGH-BITS-COUNT (OR BUS-DATA-RQ 

(AND COUNT-UP BUF-AB) 
_- _ (AND (NOT COUNT-UP) (NOT BUF-A8)})) 

(SETQ ADR-CLK (OR (AND SPV-DflA-ENB SPy-OHA-SYNC) 

;; Uhen writing froni bus, clock, adr then do write 

(AND BUS-DATA-RQ URITE-T58) 

i; Uhen reading to bus, don* t dock adr until end of cucie 

(AND BUS-OATA-RO BUS-R^AOl ^ 

(AND URITE-ADR URITE-TSB))) 
(SETQ BUF-A8 (OR (AND (NOT URITE-ADR) (NOT BUF-AB)) 

(AND URITE-ADR BUS-D0))) 
(SETQ SPY-DTIA-ENB-LB (AND (NOT BUF-AB) SPY-DflA-ENB) ) 
(SETQ SPY-DMA-ENB-HB (AND BUF-A8 SPY-DHA-ENB) ) ) 



SCRC : <LFEP>DYNMEM . PAL ; 15 

-«- node:LISP; Package:USER; Base:18 -«- 

;; Dgnaaic Memory control sicrocode 

;; Tialng based upon ISnhz clock 

;; ((state refresh-rq (and wm-rq any-rq-eync) refresh) nstate ...) 
((8888) RasAdr) 

;; Here when a normal memory request received 

((8x18) 1 Ras RasAdr) ;Address is already there 

((1 X 1 8) 2 Ras) tSetup CAS part of address 

((2 X 1 8) 3 Ras Cas) ;Now CAS it 

((3 X 1 8) 5 Ras Cas) 

((5x18) S Ras Cas AcR) {Address ts ignored, ack data 

((5x88) 7) 

((7 X K x) 8 RasAdr) 

:; This ts refresh cycle (same timing as normal cucle, for PAL) 

((8181) 1 Refresh) ;One cycle for address setup 

(d 1 X 1) 2 Ras Refresh) 

((2 1 X 1) 3 Ras Refresh) 

((3 1 X 1) 4 Ras Refresh) 

((4 X X 1) B Ras Refresh) 

((G X X 1) 7) 

((7 X X x) 8 RasAdr) 

;; Logic equations for PAL compiler 

(defpal DYNtlEn PAL1BR8 
;: Inputs — refresh request, memory request, and the synchronizer signal used 
;: to gate memory request 
(IPIN 9 REFRESH-RQ H) 
(IPIN 8 MEn-RQ L) 
(IPIN 7 ANY-RQ-SYNC H) 
;: Use all registered outputs 
(^IN 12 STATE-8 L) 
(RPIN 13 STATE-1 L) 
(RPIN 14 STATE-2 L) 
(RPIN 15 CAS L) 
(RPIN IS RAS L) 
(RPIN 17 RASADR L) 
(RPIN 18 REFRESH L) 
(RPIN 19 AC< H) 

(FIELD STATE STATE-2 STATE-1 STATE.8) 

;; Refresh turns on or off at state 8, turns off at state G, else remains the sane 
;t Normal cycles have priority over refresh cycles 

(SETQ REFRESH (OR (AND (FIELD STATE 8) REFRESfl-RQ (NOT (AND MEn-RQ ANY-RQ-SYNC))) 
(AND (NOT (FIELD STATE 8)) (NOT (FIELD STATE G)) REFRESH))) 

;; RAS is neyer on in states 6 or 7 

;t RAS comes on in state 8 if a norma i cycle is starting 
(SETQ RAS (AND (NOT (AND STATE-1 STATE-2I) 
(OR (NOT (FIELD STATE 8)) 

(AND (FIELD STATE 8) (AND HEfl-RQ ANY-RQ-SYNC))))) 

;; CAS in certain states during normal cycle, 
;: and hold CAS in state 5 until request goes away 
(SETQ CAS (AND (NOT REFRESH) ^ y y 
(OR (FIELD STATE 2) 

(FIELD STATE 3) 

(AND (FIELD STATE 5) (AND f1En-RQ ANY-RQ-SYNC))))) 

;: ACK in state 5 until memory request goes away 

(SETQ ACIC (AND (AND Pl£n-RQ AN7-RQ-SYNC) (NOT REFRESH) (FIELD STATE S)}) 

\k%^'^SA?^n\^^'\^^^^^^^ "°^"^' ••'^^^^ ^^^'^^ *"^ °^^ ^"^'"= ^^^^^ 

(NOT (FIELD STATE 1} > (NOT (FIELD STATE 2)) 
(NOT (FIELD STATE 3)) (NOT (FIELD STATE 5)))) 
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;: Lou order bit of state 

(SETQ STATE-8 (OR (AND (FIELD STATE 0) (AND MEn-RO ANY-RQ-SYNC) ) 

(AND (FIELD STATE 2) (NOT REFRESH)) 

(AND (FIELD STATE 3) (NOT REFRESH)) 

(AND (FIELD STATE 5) (NOT REFRESH)) 

(AND (FIELD STATE 6) REFRESH))) 

;: Next bit 

(SETQ STATE-1 (OR (AND (FIELD STATE 1) (NOT REFRESH)) 
(AND (FIELD STATE 2) (NOT REFRESH)) 

\1'^ {^111:8 l]l]l !1 S^^r^^"' "^°^ '*^ "^"-«° ANY-RQ-SYNC), 

(AND (FIELD STATE 2) REFRESH) 

(AND (FIELD STATE 4) REFRESH) 

(AND (FIELD STATE 6) REFRESH))) 

;; High order bit of state 

(SETQ STATE-2 (OR (AND (FIELD STATE 3) (NOT REFRESH)) 
(AND (FIELD STATE 5) (NOT REFRESH)) 
(AND (FIELD STATE 3) REFRESH) 
(AND (FIELD STATE 4) REFRESH) 
(AND (FIELD STATE B) REFRESH)))) 



SCRC:<LFEP>DYNCTL.PAL:7 

;;; -«. flodei LISP; Base: 10; Package: USER -«- 

(DEFPAL DYNCTL PAL16L8 

(OPIN 12 PARITY-ERROR L) 

(OPIN 18 ACK H) 

(OPIN 17 UE-LOU L) 

(OPIN IS UE-HIGH L) 

(OPIN 14 CAS-nPX L) 

(IPIN 11 RAfl-PARITY-LOU H) 
(IPIN 9 RAH-PARITY-HIGH H) 
(IPIN 8 BUS-PAR I TY-LOU H) 
(IPIN 7 BUS-PARITY-HIGH H) 
(IPIN 5 LOU-BYTE L) 
(IPIN 5 HIGH-BYTE L) 
(IPIN 4 nUTC H) 
(IPIN 3 AC<-RQ H) 
(IPIN 2 RQ L) 
(IPIN 1 REFRESH L) 
(IPIN 13 PROC-CYC-RAS L) 
(IPIN IS MRDC H) 

'• SW^'E!^"^^^ IS asserted during the idle ti«c, thus driving the processor 
;s RAS address iiost of the tiae. Uhcn it turns off, and a refresh cycle isn't 
;; happening, CAS-HPX comes out one PAL-delay time later. This g' 
:; amount of time for the RAS address to become non-driven, and a 
;; amount of time for the CAS address to be driven before CAS 
(§ETQ CAS-nPX (AND (NOT REFRESH) (NOT PROC-CYC-RAS) ) ) 



ives a decent 
tso a reasonable 



(SETQ UE-LOU (AND HUTC LOU-BYTE)) 
(SETQ UE-HIGH (AND HUTC HIGH-BYTE}} 

(SETQ AOC (AND RQ ACK-RQ 
(OR nUTC 

(AND (OR (NOT LOU-BYTE) 

(AND RAn-PARITY-LOU BUS-PARITY-LDU) 
(OR InS? ag$?i^''^''"'°"^ (NOT BUS-PARITY-LOU))) 
(AND RAH-PARITY-HIGH BUS-PARITY-HIGH) 
(AND (NOT RAfl-PARITY-HIGH) (NOT BUS-PARITY-HIGH))))))) 

(SETQ PARITY-ERROR 

(AND RQ ACK-RQ tlRDC 

(NOT (AND (OR (NOT LOU-BYTE) 

(AND RAM-PAR I TY-LOU BUS-PARITY-LOU) 
(OR laS? fi?M7i^^^''-^^^ (NOTBUS-PARITY-LOU))) 
(AND RAH-PARITY-HIGH BUS-PARITY-HIGH) 
(AND (NOT RAH-PARITY-HIGH) (NOT BUS-PARITY-HIGH) ) )) ) ) ) 
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SCRC : <LPEP>OEVNUM . PAL ; 8 

;-«- node:LI5P; Package:USER; Base: 18 -»- 



(defpal 

(IPIN 


DEVNUn PALiBLS 


11 


A8 


H) 


(IPIN 


9 Al 


H) 


(IPiN 


8 


A2 


H) 


(IPIN 


7 


A3 


H) 


(IPIN 


6 


A4 


H) 


(IPIN 


5 


AB 


H) 


(IPIN 


4 


AG 


H) 


(IPIN 


3 


A7 


H) 


(IPIN 


2 


AS 


H) 


(IPIN 


1 


A9 


H) 


(IPIN 


13 


Aie H) 


(IPIN 


14 


All 


. H) 


(IPIN 15 


A12 


: H) 



(OPIN 12 DEVa L) 

(CFIN 19 DEVI L) 

(OPIN 17 DEV2 L) 

(OPIN 18 DEV3 L) 

(FIELD HAS A12 All A10 A9 A8) 

(FIELD HA10 A12 All AlB A9 A8 A7 AS AS A4 A3) 

(SETQ UART (FIELD HA18 «fo20)) ' 

(SETQ SPY (AND (FIELD HAS tfo0) (NOT A7) AG)) 

(SETQ 8-B IT-REGS (FIELD HAie ;yo34)) 

(SETQ PADDLE-ID (AND (FIELD HAS ffoQ) A7 (NOT AS) A53 ) 

(SETQ LOCAL-ID (AND (FIELD HAS ffoB) A7 AB (NOT ASJi) 

(SETQ OnA-HIGH-ADR (AND (FIELD HAie ;(ro21) A2) ) 

(SETQ OnA-CONT (AND (FIELD HAS #00) A7 (NOT AS) (NOT AS) A4)} 

(SETQ HS-BUF (FIELD HA10 ^SfoSS)) 

(SETQ NANOFEP (AND (FIELD HA10 tfo27) A2 (NOT Al))) 

(SETQ CART (AND (FIELD HA10 ^o37) A2 AD) 

(SETQ LBUS-CTL (AND (FIELD HA10 ;Sro3S) (NOT A2) (NOT Al))) 

(SETQ SERIAL -BAUD (AND (FIELD HA10 *fo3S) A2)) 

(SETQ PIO (AND (FIELD HA10 ;;fo37) (NOT A2))) 

;: Decode lou bite of addreee into device number 
(SETQ DEV0 (OR UART 

8-B IT-REGS 

LOCAL- ID 

DHA-CONT 

HS-BUF 

CART 

SERIAL-BAUD)) 
(SETQ DEVI (OR SPY 

8-B IT-REGS 

DHA-HIGH-ADR 

DHA-CONT 

NANOFEP 

CART 

PIO)) 
(SETQ DEV2 (OR PADDLE- 10 

LOCAL- ID 

DnA-HIW-ADR 

DMA-CONT 

LBUS-CTL 

SERIAL-BAUD 

PIO)) 
(SETQ DEV3 (OR HS-BUF 

NANOFEP 

CART 

LBUS-CTL 

SERIAL -BAUD 

PIO))) 

;;; -«- Hode: LISP; Base: 10; Package: USER -«- 

(defpal DEVACK PALIBLS 

(IPIN 11 DEV0 L) 

(IPIN 9 DEVI L) 

(IPIN 8 DEV2 L) 

(IPIN 7 DEV3 L) 

(IPIN B T100 H) 

(IPIN 5 T200 H) 

(IPIN 4 T400 H) 

(IPIN 15 lORC-OR-IOUC H) . 

(IPIN 16 ADR-15-13-0 H) 
(IPIN '17 lOUC H) 

(IPIN 18 lORC H) 

(OPIN 12 ANY-DEVICE-RQ L) 
(OPIN 19 8-BIT-AC< L) 
(OPIN 13 IB-BIT-ACK L) 
(OPIN 15 lORC-OR-IOUC-OUT H) 
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(FIELD DEVNUn DEV3 DEVZ DEVI DEV8) 

;; This nau want to be generated faster externally at tone point 
(§ETQ lORC-OR-IOUC-OUT lOR lORC lOUO) 

;; Any request uith non-zero device number and 10 read or urite req 

(§£TQ ANY-OEVICE-RQ (AfC (C3R DEV8 DEVI DEV2 DEV3) ADR-15-13-8 IDRC-OR-IOUC)) 

;t Ack tieing is just a function of the hardware 
(§£TQ S-BIT-AOC (OR (AND (FIELD DEV^;u^ ffol) 1403 lORC-OR-IOUC) 
(AND (FIELD DEVNUH #o2) 1409 lORC-DR-IDUC) 
(AND (FIELD DEVNUH JSfoS) T100 lORC-OR-IDUC) 
(AND (FIELD DEVNUn Uo^) T200 IDRC) 
(AND (FIELD DEVNUn #o5) T200 IDRC) 
(AND (FIELD DEVNUPI UoS) T400 lORC-OR-IOUC) 
(AND (FIELD DEVNUn #o7) T400 IDRC-DR-IDUC))) 
(SETQ IS-BIT-AOC (OR ; (AND (FIELD DEVNUH *oll lORC-DR-IDUO) sBuffer ack external 
(AND (FIELD DEVNUn #ol2) T100 IDRC-OR-IOUC) 
(AND (FIELD DEVNUn )tfol3) T100 IDRC-OR-IDUC) 
(AND (FIELD DEVNUn ;?ol4) T100 IDRC-DR-IDUC) 
(AND (FIELD DEVNUn #ol5) T400 IDRC-DR-IDUC) 
(AND (FIELD DEYNUtt #ol6) T180 lORC-OR-IDUC)))) 



SCRC:<LFEP>LBBUFC,UC0DE;27 

;;: -«- f1ode:LISP; P3Ckage:USER; BasexS; Lowercase:! -»- 

;;; Three proes, aight bits each (0 is low order, 23. is high order bit), 9 address bits 
(proKs 8 3 9) 

;;: Define data format: mask for conplensented outputs, next-state, test, outputs 
(data 04007200 0005 (2503 tests) outputs) 

;;; Names for outputs. The values get XOR'ed into the conp(emented outout mask, 
(define outputs ((reg-to-ram 2!?^) (tdie 403) fbuf-ce J036) (buf-we 2Sdd) (cik-rcg 4000) 

(run-lbus 10003) (mb-control ied-ce 2QBB2} (set-ack 40300) (bus-to-ram 100330) 

(ctear-anu-request 4330303) 

(select-adr 000) (select-high 040) (setect-lou 100) (setect-med 140))) 

;;: Format of address specifier: (reset writeZ-read state test) 
(address 0701 0801 010S 0031) 

;;; The names of the conditions themselves 

(define tests ((0 0) (11) (dont-nced-tbus 2) (any-request 3) (not-no-request 4) 
(Ibus-ackS) (no-par i ty-error B) (id-request 7))) 

IGmhz clock 

((reset write/-read state cond) next-state condition-select •..) 
select-adr 00 

-high 01 

-low 10 

-med 11 

reg-to-ram, bus-to-ram, set-ack, mb-controMed-ce, run-lbus, clk-reg, 
buf-we, buf-ce, idle, clear-any-rcquest 

0, 1, dont-need-Ibus, any-request, not-no-request, Ibus-ack, no-parity-error, id-request 

any-request can only set uhtia tdln tn set 

Reset 

Clear outstanding request, and generate clk-reg, which will cause the parity error 
;;t latch to get cleared 
((1 X X x) (00 (clear-any-request clk-reg))) 

it; Idle, wait for a request 

((0 X 00 0) (00 any-request (idle select-adr))) 

;;; Read 

((0 00 1) (01 dont-need-Ibus (buf-ce select-adr clear-any-request))) 

;;; Read from the ram (a0 and al externally selected) 

;;; tM* This wilt latch into some random latch, which is ok, but will also set the 

;;; parity error ff, so that the ack won't happen if there is a parity error warn 

((0 01 1) (03 1 (buf-ce clk-reg))) 

;;; Ack won't get set if a parity error has occured since the last dispatch 

((0 33 1) (03 not-no-request (buf-ce set-ack))) 

((3 33 0) (03 3 (idle))) 

; ; ; Read from the Lbus (a0 and al come from ucode) 

((3 3 31 0) (34 id-request (Duf-ce clk-reg select-adr))) 

;;: The hardware won't start the Lbus if there ts a parity error here 

((0 04 0) (05 no-parity-error (sefect-low run-lbusl)) 
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;;: ID request cycle -- skip Lbu3 cycle, and assume data bits in latches ara valid. 
;;; ihis works as follows: you write the eppropriate address bits as usuak then 
;;: do. a read cycle. The read cycle latches the address bits into the latches, which 
;;; are be mg dr i ven onto the. bus as the address continuously. The correct data cotaes 
:;; back somet.me later, and >s Jatched on every LEUS UP. The read cycle completes 
;;; returning possibly garbage data. The Hultibus processor waits a while, to be sire 
::; the correct data has been latched, and then repeats the identical read cue te. which 
Wk i°%f^J *;^2'^3« *h« address, but does return the correct data. 

C 84 1) (12 (seiect-lou reg-to-rsm) ) ) 

3 12 0) (12 1 (select-low reg-to-ra/Ti) ) J 

m ? H }\ iJi i^ot-no-request (select-lou reg-to-ran sot-acK))) 
(la 8 13 9) lee e^lTS?;))?""' ^»^'^=^-'°" reg-to-ra. set-ack))) 

;;: Parity error in buffered address. Don't do Lbue cycle. Try to tot ack, but it 
V)l S°5^^ft?=^:i?"y 3^*^ *^» nultibus because of the parity error, 
((e 8 05 0) (03 not-no-rcquest (buf-ce set-ack))) 

Via S^Q-®?? 9SP*y '* °*^» 80 ^0 the Lbus cycle 
m a i? l\ \B tjus-ack (select. low buf-ce buf 
((3 ee 8) (C6 Ibu3-ack (select-low buf-ce buf 

!;5 «4c:« This assumes that the changing of the a _ «.„^,. ,,,^„ ,„_ 

«* HnlH*:®IJ^'?i* °'^"^' ^° "3 by at least the write recovery tiSe (Bns) 
::: ^ "? '?/':[*■ "?"° ®° need-lbus stays asserted, forcing all ra« writes to the full 16 hits 
rd fi°rt !??"?i4*'® '°" *^^t3 until the request goes away * ^"^' ^^ ^'**- 

ft R 17 t i4 noJ-no-'-equest (select-low reg-to-ra» set-ack run-lbus))) 
::: Ur i t.^lhi^meSiu^^S^rd'^"'' (celect-low reg-to-rae sot-ack run-lbus))) 
((0 n7 m Ifl7 ? {s^'ect-med rea-to-ram run-lbus))) 

07 ? nl ft '^^ct-rtea bu?-ce buf-we reg-to-raw run-lbus))) 

ift R « ? 5eec:-med buf-ce buf-we reg-to-ram run-lbus))) 
M« 10 0) (10 1 (seiect-high rcg-to-ram run-Tbus))) 

(C0 18 1) Cll e (select-high buf-ce buf-we reg-to-ra« run-lbus))) 

?;; Unte the high word into ram 

((8 8 U 8) iBB B (select-high buf-ce buf-we reg-to-rae run-lbus))) 

;;: Urite 

((8 1 88 1) (82 don t-need- lbus (buf-ce select-adr clear-any-request))) 

:;: Urite to the ram (a8 and al externaMy e^iected) 

\\k i^^^l?^^LH S'ock a register here, wh^ch wi i f clear the parctu error latch) 

((0 1 02 1) (03 (buf-ce buf-we bus-to-ram crk-rccH> 

((0 1 83 8) (84 1 (buf-ce buf-we bus-to-ram))) 

((8 1 84 1) (04 not-no-request (set-ack))) 

ae 1 84 8) (88 8 (idle>)r 

;;; Urite to the Lbus (a0 and al come frca ucode) 

((8 1 82 8) (05 8 (buf-ce clk-reg select-adr)) ) 

1(8 1 85 8) (0S no-parity-error (8olect-«ed bus-to-ra«) ) ) 

\\h l^flK^Hi'TSf^I? S"^!r*'^ address. Don't ack nb, and don't start Lbus cycle 
no 1 Ob 8i 104 not-no-request (set-ack) H 

the Lbus 
the worst 
' /«V**Pi*^'7" '** ^"*** °"* °^° "°''° "*'* Q®^ wrrtten into the Lbus- 
frt» 1 0-, a. fo^ f ("b-controMed-ce selcct-med dus-to-ram) )) 

P 1 R7 ? nl a =t5-controlied-ce se I ect-«ed bus-to-ram clk-reg))) 
} i } rl U f}5 ? tii^^-ce select-low run-lbus))) 
i } }§ ? }? i buf-ce select-low clk-reg))) 
8 1 18 1) (11 (buf-ce select-high))) 
((8 1 11 8) (11 1 (buf-ce scfect-high clk-reg))) 

Vih l^il l?^12''lbuf"ac^Ueta^k)))^^'■'^"^^^ ''''* ^'"'''''"* ^^^ '^ P^'"'*^ *^^°^ '" '""' 

((8 1 12 8) (12 Ibus-ack (set-ack))) 

((8 1 12 1) (84 not-no-request (set-ack))) 



SCRC:<LFEP-X>FPCEXT,PAL;2 

;-«- node:LISP; Package:USER; BasetlS -«- 

(defpal FPCEXT PAL16L8 

(IPIN 11 EXT-BUS-HASTER L) 

(IPIN 4 EXT-DIR-CTL L) 

(IPIN 8 lORC L) 

(IPIN 7 riRDC L) 

(IPIN 5 EXT- I NT-PRESENT H) 

S K 2 URITE-T58 L) 

(IPIN 6 Al H) 

(IPIN 9 PIO-RQ L) 

(IPIN 3 NFEP-RQ L) 
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(OPIN 17 EXT-DATA-TO-BUS H) 

(OPIN 18 EXT-DRIVE L) 

(OPJN 13 EXT-BUS-HASTER-OUT H) 

(OPIN 14 PIO-UR-CTL L) 

(OPIN 13 PIO-RD-CTL L) 

(OPIN IB FEP-NFEP-UR L) 

(OPIN 15 FEP-NFEP-RD L) 

(OPIN 12 EXT-INT-PRESENT-OUT L) 

(SETQ EXT-INT-PRESENT-OUT EXT-INT-PRESENT) 
SEJQ EXT^US-MASTER-OUT EXT^US^ASTER) 
(SETQ EXT-DATA-TO-eUS (COND ((NOT EXT-INT-PRESENT) NIL) 

((AND EXT-INT-PRESENT EXT-BUS-TIASTER) 
(NOT (OR lORC riRDC))) 

((AND EXT-INT-PRESENT (NOT EXT-BUS-riASTER) ) 



SCRC:<LFEP-X>FPCBPE.PAL;3 

$-»- nod«:LI5P; PackagtzUSER; Bate: 18 -»- 

;; Bi -phasa decoder pat for the console link 

(DEFPAL FPCBPE PAL16R8 
; pin 1 is 4.9152 IIHr clock 
(IPIN 2 ENCOOED-INPUT) 

(RPIN 19 RXD-SYNC) 
(RPIN 18 RXD-DLY) 
(RPIN 17 TRANSITION) 
(RPIN 16 SEQUENCER) 
(RPIN 15 RCV-CLO 
(RPIN 14 HASO 
(RPIN 13 SAflPLE) 
(RPIN 12 DECODED-OUTPUT) 

(SETQ RXD-SYNC ENCODED- INPUT) jSunchronize input data to local clock 

(SETQ RXD-OLY RXD-SYNC) ;Second-half of synchronizer 

(SETQ TRANSITION (XOR RXD-SYNC RXD-OLY)) ^edge detector 

(SETQ SEQUENCER (AND (NOT flASJC) (OR TRANSITION SEQUENCER))) jStart sequence 

(SETQ RCV-aiC (NOT SEQUENCER)) {recovered clock 

(SETQ HAStC (NOT RCV-CLK) ) *aa8k out aid-bit transitions 

(SETQ SAttPLE (COND ((AND SEQUENCER RCV-aiC) RXD-OLY) ; sample first half data 
((NOT (AND SEQUENCER RCV-CLO) SATIPLE))) 

(SETQ DECOOED-OUTPUT (COND ((AND RCV-aiC MASJC) (XOR (NOT RXD-OLY) SATIPLE)) ;recovered data 

((NOT (AND RCV-CLIC flASK)) DECODED-OUTPUT)) ) 

:; end of def tni t ion 



SCRC : <LMI FU>ERROR . PAL ; 1 

; -«- node: Lisp; Package: User; Base: 18 -«- 

; This PAL detects and latches error conditions 

(DEFPAL ERROR PAL16R4 
;; Inputs 

(iPlN 12 DOUBLE-ERROR-B L) 
(IPIN 2 DOUBLE-ERROR-A L) 
(IPIN 3 HAP-SEL-l) 
(IPIN 4 HAP-SEL-B) 
(IPIN 5 ADDR-FROn-HAP) 
(IPIN 6 HAP-TO-ABUS Li 
(IPIN 7 PROC-GRANT L) 
(IPIN 8 rtAP-PAR-ODD) 
(IPIN 9 SPY-ERROfl-RESET L) 
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:; Noraal outputs 

J^IK }f !iF?;SS°r7^' '^^ "OCTL pipeline 

(OPLN 18 nC-STOP L) :to SQ. to etoo Mchins 

(OPIN 13 DOUBLE-ECC-ERROR L) I to FEP, to caCsebui error if FEP read 

;: Registered outputs (to spu bus) 
:{RPIR 17 SPARE) ^ 

(RPIN 16 flAP-B-LOST) 
CRPIN IS rtAP-A-LOST) 

(RPIN 14 nen-LOST) 

:i Decode sap parity errors 
(FIELD riAP-SEL HAP-SEL-l tlAP-SEL-e) 

{§ilS yfi^^-P^KJ^^ /Ji^° PRX-GRANT ADDR-FROfl-riAP) nAP-TO-ABUS) ) 
SETQ flAP-A-ERROR (AND USlNG-riAP (NOT flAP-PAR-ODO) (FIELD HAP-SEL 1))) 
(SETQ HAP-B-ERROR (AT© USl^G-ttAP (NOT nAP-PAH-ODD) iFlELD nAP-SEL 2))) 

XI Stop Bachine if any error 

;; Double-bit error (uncorrectable ECO cones in on two pins because the PAL 

111 R%SK0^^ ^[;iLljR"R°0"§^ra^^.|^^^^^^ '^ -"P'«*«'« 

(SETQ nC-STOP (OR DOUBLE -ECC -ERROR flAP-A-ERROR IIAP-B-ERROR}} 

{i Error latches 

JiilS KiXI"D!n-^OSLi^^ ^^^ SPY-ERROR-RESET) (OR DOUBLE-ECC-ERROR tEM-LOST))) 
SETQ NEXT-HAP-A-LOST (AND (NOT SPY-ERROR-RESET) (OR HAP-A-ERROR HAP-A-LOST 
(SETQ NEXT-riAP-B-LOST (AND (NOT SPY-ERROR-RESET) (OR ftAP-B-ERROR nAP-B-LOST) ) ) 

U^5S^i2S^"t;£l^*'" *his wemoru cycle is getting its lou-order address bits fro» VMA 
(SETQ ADOR-FROn-VriA (AND ADDR-FROn-rtAP InOT (FIELD MAP-SEL 5))))) 

; -*- f1ode:Lisp; PackagetUser; BasetlB -»- 

; Destination control, aap LRU algorith*, and skip condition select 

(DEFPAL DEST PAL16L8 
;! nicroinstruct ion Inputs 
(IPIN 7 URITE-nC-D£V L) 
(IP IN 8 LBUS-DEV-2) 
(IPIN 9 LBUS-OEV.l) 
(IPIN 11 LBUS-DEV-0) 
(FIELD SUBOEVICE LBUS-OEV-2 LBUS-DEY-1 LBUS-DEV-g) 

; : flap Controls 

(IPIN A HAP-B-LRU) 

(IPIN 5 SPY-nAP-B-ENABLE L) 

(IPIN 6 SPY-PIAP-A-ENABLE L) 

; : Skip Condi t ions 
(IPIN 2 ECC-ERROR L) 
(IPIN 3 HAP-A-VnA-nATCH L) 

;: Outputs 

(OPIN 17 nC-COND) 

(OPIN 16 LOAD-PC L) 

(OPIN 15 LOAO-PHTA-AND-ASN L) 

(OPIN 13 URITE-HAP L) 

(OPIN 19 riAP-B-URITE) 

(OPIN 12 HAP-A-URITE) 

•i^tS^s ^5v'C« write destination decode 

Ills i-S^S-Ey^^:5.IP-ji?!!!^^^^^° URITE-nC-DEV (field SUBDEVICE 1))) 
(SETQ LOAD-PC (AND URITE-HC-DEV (FIELD SUBDEVICE 2))) 
(SETQ URITE-HAP (AND URITE-HC-DEV (FIELD SUBDEVICE (4 5 6 7)))) 

;; LOAD-VnA control is on HDCTL PAL. 

;: Choosing which nap to write 
(SETQ flAP-A-URITE (AMD URITE-HAP 

(OR (FIELD SUBDEVICE (5 7)) 
(AND (FIELD SUBDEVICE 4) 
(OR (NOT MAP-B-LRU) 
(SETQ ttAP-B-URITE (AND WRITE-HAP '*^' SPY-TIAP-B-ENABLE) ) ) ) ) ) 
(OR (FIELD SUBDEVICE (B 7)) 
(AND (FIELD SUBDEVICE 4) 
(OR flAP-B-LRU 

(NOT SPY-riAP-A-ENABLE) ) ) ) ) ) 

;: Skip condition select 

(SETQ ftC-CONO (COND (LfBI TE-HAP rtAP-A-VHA-riATCH) 

(INOT URITE-nAP) ECC-ERROR)))) 

;-«- node:LISP; Package:USER; Base:18 -»- 

(CEFPAL DECODES PALieHS 
(IPIN 1 ECC-CORRECT-CLK) 
(IPIN 2 SYN-6 L) 
(IPIN 3 SYN-5 L) 
(IPIN 4 SYN-4 L) 



1221 
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(IPIN B SYN-3 L) 
(IPIN 6 SYN(.2 L) 
(IPIN 7 SYN-1 L) 
(IPIN 8 SYN-e L) 
(FIELD SYN SYN-6 



SYN-5 SYN-4 SYN-3 SYN.2 SYN-1 SYN-0) 



(OPIN 
(OPIN 
(OPIN 
(CFIN 
(OPIN 
(OPIN 
(OPIN 
(OPIN 

(SETQ 
(SETQ 
(SETQ 
(SETQ 
(SETQ 
(SETQ 
(SETQ 
(SETQ 



19 ECC-CORRECT-S) 
IS ECC-CORRECT-9) 
17 ECC-CORRECT-10) 
IB ECC-CORRECT-11) 
15 ECC-CDRRECT-12} 
14 ECC-CORRECT-13) 
13 ECC.CORRECT-14) 
12 ECC-CORRECT-IS) 

ECC-CORRECT-8 (AND ECC-CORRECT-CLK 
ECC-CORRECT-S (AND ECC-CORR£CT-CL< 
ECC.CORRECT-10 (AND ECC-CORRECT-CLK 
ECC-CORRECT-11 (AND ECC-CORRECT-CK 
ECC-CORRECT-12 (AND ECC-CORRECT-CLK 
ECC-CORRECT-13 (AND ECC-CORRECT-CLK 
ECC-CORRECT-14 (AND ECC-CDRRECT-CUC 
ECC-CORRECT-IS (AND ECC-CORRECT-CU 



(FIELD SYN #0015))} 
(FIELD SYN )(ro816))) 
(FIELD SYN J!^oll7))) 
(FIELD SYN #ol21))) 
(FIELD SYN #ol22))) 
(FIELD SYN «fo023))) 
(FIELD SYN #0124))) 
(FIELD SYN #0025))}) 



t-«- ftod«:LISPi PackagetUSER; Bate: 10 -«- 
(DEFPAL DEC00E32 PALISLS 



(IPIN 1 ECC-CORRECT-CLK) 

(IPIN 2 SYN-S L) 

(IPIN 3 SYN-5 L) 

(IPIN 4 SYN-4 L) 

(IPIN 5 SYN-3 L) 

(IPIN 6 SYN-2 L) 

(IPIN 7 SYN-1 L) 

(IPIN 8 SYN-0 L) 

(FIELD SYN SYN-6 SYN-5 SYN-4 SYN-S SYN-2 SYN-1 SYN-0) 

;: Kludge because not enough product terms. Clobber these bits if double-bit error 

(flELD SYN6 SYN-5 SYN-4 SYR-3 SYN-2 SYN-1 SYN-0) oouoie bit error 

(IPIN 9 SYN-NOT-0) 
(IPIN 11 OOD-NUn-ERRORS) 

(OPIN 16 DOUBLE-ERROR-B L) 
(OPIN 15 DOUBLE -ERROR-A L) 
(OPIN 14 ECC-CORRECT-35} 
(OPIN 13 ECC-CORRECT-34) 
(OPIN 19 ECC-CORRECT-33) 
(OPIN 12 ECC-CORRECT-32) 



;150 



(SETQ ECC-CORRECT-32 (AND ECC-CORRECT-aiC (FIELD SYN6 #o60) ) ) 

(SETQ ECC-CORRECT-33 iANO ECC-CORR£CT^LK (F ELD SYN6 SoGl 

(SETQ ECC-CORRECT-34 lAWD ECC-CQRR£CtIclK IF IlO SYWS #^62 

(SETQ ECC-C0RRECT.35 (AND ECC-CORREEtIcU (FIELD SYN6 ffost))} 

j; Double bit error if syndrore not 8 and even nuaber of errors (paritg of sundroae) 
;; or i f one of the unused codes is encountered. •tf"uro«c; , 

;; These include sons double-bit errors and sone replications in order to 

\k?Q^OOUBLE-iRR^R!A"()(^'£88f6SR^^^ """^•'' °* ^'''^^' *•— 

(OR (AND SYN-NOT-0 (NOT ODO-NUn-ERRORS) } 
(FIELD SYN #0(131 132 133 135 136 137 
151 152 153 155 156 157 
161 162 163 165 166 167 

(SETQ OOUBLE-ERROR-B (AND ECC-CORRECT-aK ''' ''^ ''^ ''^ ''^ '''''''' 

(OR (AND SYN-NOT-0 (NOT ODO-NUfl-ERRORS) ) 

(FIELD SYN #0(070 071 072 073 074 075 076 077 174 
027 037 047 067 127 137 147 167)))})} 

:-«- ftode:LISP; PackagetUSER; Base: 10 -«- 

(DEFPAL DEC0DE24 PAL10H8 
(IPIN 1 ECC-CDRRECT-atC) 
(IPIN 2 SYN-6 L) 
(IPIN 3 SYN-5 L) 
(IPIN 4 SYN-4 L) 
(IPIN 5 SYN.3 L) 
(IPIN 6 SYN-2 L) 
(IPIN 7 SYN-1 L) 
(IPIN 8 SYN-0 L) 



(FIELD SYN SYN-6 SYN-5 SYN-4 SYN-3 SYN-2 SYN-1 SYN-0) 



(OPIN 
(OPIN 
(OPIN 
(OPIN 
(OPIN 
(OPIN 
(OPIN 
(OPIN 



19 ECC- 
18 ECC- 
17 ECC- 
16 ECC- 
15 ECC- 
14 ECC- 
13 ECC- 
12 ECC- 



.C0RRECT.24) 
€0RRECT-25) 
.CORRECT-26) 
CORRECT-27) 
.CORRECT-28) 
-CORRECT-29) 
.CORRECT-30} 
-C0RRECT.31) 



(SETQ ECC- 

(SETQ ECC- 
(SETQ ECC- 
(SETQ ECC- 
(SETQ ECC- 
(SETQ ECC- 
(SETQ ECC- 
(SETQ ECC- 
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-CORRECT-24 
.CORRECT-25 
.C0RRECT-2S 
■CORRECT-27 
CORRECT-28 
C0RRECT.23 
CORRECT-30 
CORRECT-31 
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(AND ECC-CORRECT-a< (FIELD SYN #ol44))) 

(AND ECCCORRECT-CLK (FIELD SYN ^oBAB))) 

(AND ECC-CORRECT-CL< (FIELD SYN ^0946))) 

(AND ECC-CDRRECT-CLK (FIELD SYN iiolBd))) 

(AND ECC-CORRECT-CL< (FIELD SYN tfodSl))) 

(AND ECC-CORRECT-CLK (FIELD SYN ffoSSl))) 

(AND ECC-CORRECT-CLK (FIELD SYN ;t?ce54))} 

(AND ECC-CORHECT-CLK (FIELD SYN fiodS?})}) 
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;-«- f1ode:LISP: PackageiUSER; Baseiie -»- 
(DEFPAL DECOOEIG PAL10H8 



(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 



ECC-CORRECT-CUC) 
SYN-6 L) 
SYN-S L) 
SYN-4 L) 
SYN-3 L) 
SYN-2 L) 
SYN-l L) 
SYN-0 L) 



(FIELD SYN SYN-6 SYN-5 SYN-4 SYN-3 SYN-2 SYN-1 SYN-8} 



(OPIN 
(OP IN 
(OPIN 
(OPIN 
(OPIN 
(OPIN 
(OPIN 
(OPIN 

(SETQ 
(SETQ 
(SETQ 
(SETQ 
(SETQ 
(SETQ 
(SETQ 
(SETQ 



19 ECC- 
18 ECC- 
17 ECC" 
16 ECC- 
15 ECC- 
14 ECC- 
13 ECC- 
12 ECC- 



•CORRECT-IS) 
•CORRECT-17) 
CORRECT-IS) 
CORRECT-19) 
tDRRECT.2e) 
■C0RRECT.21) 
CORRECT-22) 
CORRECT-23) 



ECC-CORRECT-IS 

ECC-CORRECT-17 
ECC-CORRECT-IS 
ECC-CORRECT-13 
ECC-CORRECT-29 
ECC-C0RRECT.21 
ECC-CORRECT-22 
ECC-CORRECT-23 



(AND ECC- 
(AND ECC- 
(AND ECC- 
(AND ECC- 
(AND ECC- 
(AND ECC- 
(AND ECC- 
(ANO ECC- 



■CORRECT-CLK 

■CORRECT-CLK 
.CORRECT-CLK 
■CORRECT-CLK 
•CORRECT-CLK 
■CORRECT-CLK 
■CORRECT-CLK 
■CORRECT-CLK 



(FIELD 
(FIELD 
(FIELD 
(FIELD 
(FIELD 
(FIELD 
(FIELD 
(FIELD 



SYN 
SYN 
SYN 
SYN 
SYN 
SYN 
SYN 
SYN 



«o02S))} 
tfol38))) 
#o331))) 
<ro032))) 
ffoB3^))) 
tfoHl))) 
#ol42))) 
#o843) ) ) ) 



;-»- node:LISP; Package:USER; Baae:18 -»- 
(DEFPAL 0EC00E8 PAL19HS 



(IPIN 1 ECC-CORRECT-aK) 

(IPIN 2 SYN-S L) 

(IPIN 3 SYN-5 L) 

(IPIN 4 SYN-4 L) 

(IPIN 5 SYN-3 L) 

(IPIN 6 5YN-2 L) 

(IPIN 7 SYN-1 L) 

(IPIN 8 SYN-8 L) 

(FIELD SYN SYN-S SYN-5 SYN-4 SYN-3 SYN-2 SYH-1 SYN-8) 



(OPIN 
(OPIN 
(OPIN 
(OPIN 
(OPIN 
(OPIN 
(OPIN 
(OPIN 



19 ECC- 
18-ECC. 
17 ECC- 
16 ECC- 
15 ECC- 
14 ECC- 
13 ECC- 
12 ECC- 



.C0RRECT.8) 
CORRECT-1) 
CORRECT-2) 
€DRRECT-3) 
-CORRECT-4) 
■CORRECT-S) 
•CORRECT-6) 
■CORRECT-7) 



(SETQ ECC-CORRECT-8 (AND ECC-CORRECT-CLK 

(SETQ ECC-CORRECT-1 (AND ECC-CORRECT-CLK 

(SETQ ECC-CORRECT-2 (AND ECC-CORRECT-CLK 

(SETQ ECC-CORRECT-3 (AND ECC-CORRECT-CLK 

(SETQ ECC-CORRECT-4 (AND ECC-CORRECT-CLK 

(SETQ ECC-CORRECT-5 (AND ECC-CORRECT-CLK 

(SETQ ECC-CORRECT-S (AND ECC-CORRECT-CLK 

(SETQ ECC-CORRECT-7 (AND ECC-CORRECT-CLK 

; .»- Mode: Lisp; Package: (Jser; Bata:18 -«- 

; Track ttate of bus cycles 

t Note that all outputs are registered 

(DEFPAL 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 



(FIELD 
(FIELD 
(FIELD 
(FIELD 
(FIELD 
(FIELD 
(FIELD 
(FIELD 



SYN tfol^3))) 
SYN #ol05))) 
tfoieS))) 
«fo007))) 
^olll))) 
;!'oll2))) 
ffoQ13))) 



SYN 
SYN 
SYN 
SYN 
SYN 



SYN #olI4}))) 



BUSTATE PAL16R8 

2 DONT-START-READ) 

3 LBUS-UAIT L) 

4 AODR-IN-AflEn L) 

5 SPY-OBUS-TO-LBUS) 

6 SPEC-DflA L) 

7 FEP-LBUS-RQ L) 

8 LBUS-REQUEST L) 
3 LBUS-t4RlTE L) 



(RPIN 19 DATA-CYC L) 
(RPIN 18 URITE-ACTIVE-CYC) 
(RPIN 17 READ-ACTIVE-CYC U 



?Don t toad flO from results of this read 

;Don't advance most state 

: Inhibit processor cucfe 

;FEP wants to see datapath output 

^i„«t3rt eeit cycle, it's a DttA 

;FEP wants Lbus or has active cycle 

;5o«eone is starting a cycle 

;Ur i te cycle starting 

I Any read-data cycle (for ECC) 
;Any write-active cycle 
;Anu read-active cycle 



M 
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(RPIN IS FEP-READ-ACTIVE L) 

(RPIN 15 PROC-REAO-ACTIVE L) 

(RPIN 14 nC-OBUS-REG-TO-LBUS L) ;Ppocm»op unite data to bus 

5S5IK II Syi;^yfi>iw^ .. ^R**» *'"•• •" "" ^o^ anything but processor read 
(RPIN 12 PROC-OATA-CYC L) sOata on tbus for processor read 

;; If iomeone is requesting and it*i not the FEP, it Bust be the processor 

j; If they both are requesting, the FEP atuays takes priority 

;; Ignore processor requests that aap into A*aeaory (uhich is a physical 

;; slot number that doesn* t exist) 

(SETQ PROC-LBUS-GRANT CAfiD LBUS-REQUEST (NOT FEP-LBUS-RQ) (NOT ADDR-IN-AMEri))) 

;: The PEP gets the bus if It wants it, exceot when refresh takes prioritu 
(SETQ FEP-LBUS-GRANT (AND FEP-LBUS-RQ LBUS-REQLEST)} ^ ^ 

;; Put processor write data on the bus during active cycle 
s; If active cycle stretched by Lbus Uait, keep driving data 
;; Use same path as way for FEP to read the datapath Objs 
(^TQ NEXT-flC-OBUS-REG-TO-LBUS 

(OR (AND PROC-LBUS-GRANT LBUS-URITE (NOT SPEC-DHA) (NOT LBUS-UAIT)) 
(AND nC-OBUS-REG-TO-LBUS LBUS-UAIT) 
SPY-OBUS-TO-LBUS)) 

:; Track the proqress of various cycles 

(§ETQ NEXT-PROC-READ-ACTIVE 

(OR (AND PRX-LBUS-GRANT (NOT LBLfS-URITE) (NOT SPEC-OnA) 

, (NOT LBUS-UAIT) (NOT DONT-START-REAO) ) 

,^^,« .^...^^^5 pROC-REAO-ACTIYE LBUS-UAIT))) 
(SETQ NEXT-FEP-READ-ACTIVE 

(OR (AND FEP-LBUS-GRANT (NOT LBUS-URITE) (NOT LBUS-UAIT)) 
(AND FEP-REAO-ACTIVE LBUS-UAIT))) 

; PROC DATA CYC is only on during the first cycie of a data cycle that 

■ ^S^'«-n5PSIiS^«*^y« i°>*=*"» "**^* ^^'*^ "«*^«« ^^°^^ ''•a^ froa TV aeeory work, 
Q NEXT-PROC-DATA-CYC 

(AND PROC-REAO-ACTIVE (NOT LBUS-UAIT))) 

;; The bus is busy during write active cycles and during FEP data cycles 

;: It is not busy during proc data cycles since that is accounted separately 

;; However, if a data cycle is repeated the bus is busy with garbage data 

;: during the repetitions 

(SETQ NEST-BUS-BUSY (OR (AND LBUS-REQUEST LBUS-URITE (NOT LBUS-UAIT)) 

(AND FEP.READ-ACTIVE (NOT LBUS-UAIT)) 

(AND BUS-BUSY LBUS-UAIT) 

(AND PROC-DATA-CYC LBUS-UAIT))) 

;; T'^ack all reads so ECC-corrected data can be redriven onto bus 
U£TQ"NEXT°RiAD""?VE'"cYc' ''•^'''"*"^ *° ^"** ^'^ ^^^ "°"'* ^« ^"^W^ 

^'' liKg ^E^d'-^^?^^^^^^ (HOT LBUS-URITE) (NOT LBUS4JAIT)) 

(SETQ NEXT-DATA-CYC 

(OR (AND READ-ACTIYE-CYC (NOT LBUS-UAIT)) 
(AND DATA-CYC LBUS-UAIT))) 

'(kTQ''NEXT-UR!TE-ACT?VE^^^ '°'*'' ^•'•° ^°'' •P^ciBl load HO) 

(OR ]aND LBUS-REQUEST LBUS-URITE (NOT LBUS-UAIT)) 
(AND URITE-ACTIVE-CYC LBUS-UAIT)))) 

; -»- f1ode:Lisp: Package: User; Base: 10 -«- 

s Bus arbitration (request froa processor) PAL 

(DEFPAL BUSARB PAL16L8 
:{ fltcroinstruction inputs 
(iPIN 5 U-AnRA-SEL-0) 
(IPIN 6 U-AnRA-18) 
(IPIN 7 U-AnRA-7) 
(IPIN 8 U-APtRA-S) 
(IPIN 9 U-ttEM-l) 
(IPIN 11 u-nEn-8) 
(IPIN 15 SPEC-DfIA L) 

(FIELD ASOURCE U-AnRA-7 U-AflRA-S) 

(SETQ ABUS-SOURCE (AND U-AHRA-SEL-B U-AHRA-IB)) tUe drive the Abus 

(SETQ ABUS-FROn-rEM (AND ABUS-SOURCE (FIELD ASOURCE 0))) 

(SETQ ABUS-FROn-LBUS (AND ABUS-SDURCE (FIELD ASOURCE 1))) 

(SETQ ABUS-FROn-VriA (AND ABUS-SOURCE (FIELD ASOURCE 2))) 

(SETQ ABUS-FROn-ttAP (AND ABUS-SOURCE (FIELD ASOURCE 3))) 

ti Note we only see the low 2 bits of the tlEH field. The functions are 
;; encoded so as to aake thie work. Functions 8 and 7 are the block-mode 
s; versions of functions 2 and 3. Function 5 uses the bus just like function 
;; 1 does, but writes the VttA instead of a aicrodevice. 

(^lELD u-r€n u-riEn-i u-nEn-8) 

(SETQ niCRODEVICE-OP (FIELD U-flEn D) 

(SETQ n I CRODEV ICE-READ (AND f1 1 CRODEV ICE-OP ABUS-FROH-LBUS) ) 

(SETQ niCRODEVICE-URITE (AND niCRODEVICE-OP (NOT ABUS-FROH-LBUS) )) 

{ills glSg?eEE'lE'l^Ll-[{!A^-|V^ '"^ niCRODEVICE^JRITE (NOT ABUS-FROfl-nEn) ) ) 

(SETQ START-URITE (FIELD U-ttEn 3)) 

(SETQ HEn-START (OR START-READ START-URITE)) 



4,887,235 
1227 1228 

;j NOP inhibits action of ■icroinatructionV but not wait (it*8 too slow) 

;; Note that PROC-UAIT feeds back to NOP, as does nap Miss (or any trap). 

;; Itjs necessapg to be careful to avoid feedback here. In addition, if 

;; a request to use the bus is inhibited because the bus is busy, we Bust 

;; short-circuit the path fro« WAIT to NOP, to avoid driving the bus during 

;; the ti«e required to decide to turn on NOP (in other words, go through 

;; the PAL once instead of twice), 
(IPIN 4 NOP L) 

;; PROC GRANT Must latch up when the clock is asserted. The wemorg card has 
;; already decided to take a cycle, and has started RAS, so we mustn't drop 
;; the request and mustn't change the address or the contents of nemoru will 
;; be clobbered, Ue stilt have until the trailing edge of the clock to decide 
;; whether to do a write or a read. 
(IPIN 14 CU) 

;; Reasons not to start a »c«oru cycle (higher-priority request or active) 

;; Don t start a aeinory cycle if tasking away— instead start when cone back 

;; This applies to both reads and writes: there are two reasons, to avoid 

:; getting our nO smashed on reads, and to avoid causing a OHA task to wait 

:; before starting its request. 

;; Note that the processor is allowed to start a aeiBory cycle if in its 

;; own active cycle; it is assumed to know what it is doing, fnter-task 

;; interference is prevented by not starting when tasking awau. It is inutile 

UpIN 2'fAs"su?TCH^U ***^^ * «"ory cycle in the last •icroinstruct ion of the task. 

(IPIN 3 ALLOU-PROC-GRANT L) $bus not tied up by FEP or refresh 

(SETQ nEnORY-UAIT (OR (AND START-READ (NOT ALLOU-PROC-GRANT) ) 
(AND START-URITE (NOT ALLOU-PROC-GRANT)) 
(AND PlEn-START TASIC-SUITCH) ) ) 

'(1p?"i3"buS-BUSY L? * *'^''^^*^*^« °P (conflicts for Lbus data lines) 
(IPIN 1 PROC-DATA-CYC L) 

(SETQ niCRODEVICE-UAIT 

(OR (AND niCRODEVICE-OP BUS-BUSY) 

(AND niCRODEVICE-READ PROC-DATA-CYC) 

(AND niCRODEVICE-URITE-USING-BUS PROC-DATA-CYC))) 

;; Bus control outputs 
(OPIN 18 BUS-DEV-REaD L) 

OP N 17 BUS-DEV-OR-VriA-URITE D 

OPIN 16 PROC-GRANT D 

iS K }g PROC-GRANT-FEEDBACIC D 
(OPIN 19 nC-OBUS-TO-LBUS D 

(SETQ PROC-GRANT (OR (AND flEH-START (NOT NOP) (NOT flEnORY-UAIT) ) 
(AND PROC-GRANT-FEEDBACK CLK))) : latch 

(IpTn DH|-Si^5i^° i^fiS "iCR9D£VICE-READ (NOT NOP) (NOT niCRODEVICE-UAIT) )) 
(SETQ BUS-DEV-OR-VriA-URITE (OR (AND fllCRODEVICE-URITE (NOT NOP) (NOT fi (^RODEVICE-UAIT) ) 

(AND MEn-START SPEC-DHA (NOT NOP) (NOT HEnORY-UAI T) ) ) ) 

UFTn'"Mr'^n2i.c®¥A*=fn.'1^M?.,Ji*''7j;S ^H^ "°* coming from memory 
(SETQ nC-OBUS-TO-LBUS (AND (OR niCRODEVICE-URITE-USING-BUS 

(AND niCRODEVICE-URITE (NOT PROC-DATA-CYC))) 

(NOT NOP) (NOT niCRODEVICE-UAIT))) 

;: Processor wait output. Must be fast 
(6pIN 12 PROC-UAIT L) 

:; Note: PROC-UAIT gets lORed wUh LBUS-UAIT to produce HC UAIT, the signal 

;; that actually goes to the sequencer and teiis the processor to wait. 

;; This IS done outside of the PAL to reduce the timing constraints on LBUS UAIT 

•' DDnr^MA T^u* ^f^ 1"P^^ **:•; ^°^ ^"9 fixing. It doesn* t cost any time since 
;: PROC-UAIT has to get inverted outside of the PAL anyway. 

(SETQ PROC-UAIT (OR niCRODEVICE-UAIT fTEflORY-UAIT) ) ) 

SQ - PAL 

; -»- node: Lisp; Package: User; Base: 10 -»- 

; PAL for SQTSICl, holds and priority-encodes software task wakeups 

(DEFPAL SQTSKl PAL16R4 

(RPIN 17 TASK-S-UAKEUP-FLAG) ;Register bits 
(RPIN IS TASK-S-UAKEUP-FLAG) 
(RPIN 15 TASIc:-2-UA<EUP-FLAG) 
(RPIN 14 TAS<-1-UA<EUP-FLAG) 

(IPIN 3 TAS<-3-UA<EUP-FLAG) jClock request comes in from outside 

(^IN if PRiIl U I Priority-encoded task number 

(OPIN 13 PRI-0 L) 
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(IPIN 12 CUR-TAS<-2) ;Cuppent task 

(IPIN 2 CUR-TAS<-1) 

(IPIN 3 CUR-TAS<-9) 

(FIELD CUR-TASK CUR-TASK-2 DJR-TASK-1 CUR-TASK-B) 



(IPIN 4 DISniSS L) 
(IPIN 5 HAGIC-l) 

(IPIN 6 riAGic-e) 

(FIELD HAGIC tlAGIC-l MAGIC-e) 
(IPIN 7 SET-UAKEUP L) 



(SETQ UA»CEUP"1 
(SETQ UAX:EUP-2 
(SETQ UAICEUP-5 
(SETQ UA<EUP*6 

(SETQ DlSniSS-l 
(SETQ DISniSS-2 
(SETQ DISniSS-3 
(SETQ DISniSS-4 
(SETQ DISniSS-5 
(SETQ DISniSS-S 



(AND SET-UAKEUP 

(AND SET-UAKEUP 

(Af^O SET4JA<EUP 

(AND SET-UAKEUP 



;Ditttist conaand 
sTaak to ba auakaned 

tUakeup coaaand 

{FIELD HACIC 0))) 
(FIELD ftAGIC 1)\) 
(FIELD nAGIC 2))) 
(FIELD OAGIC 2))) 



(AND DISniSS 
(AND DISniSS 
(AND DlSniSS 
(AND DISniSS 
(AND DISniSS 
(AND DISniSS 



(FIELD CUR-TASK 1))) 

(FIELD CUR-TASK 2))) 

(FIELD CUR-TASK 3))) 

(FIELD CUR-TASK 4))) 

(FIELD CUR-TASK S))) 

(FIELD CUR-TASK B))) 



Disniss-i)})) 



jPrioritu Encoding. Note uall: DISTIISS does not clear the request 
; until the foMouing cycle. Thus, for software tasks gou must 
; disaiss one cycle earlier than for hardware tasks. This is okau 
: since software tasks are not DTIA tasks, hence longer than 2 cgcTes. 
fl had to do it this uag to get the priority encoder inside the PAL. 

iHIR Sh? iSS I^iH-H^!$iHE"£!-^S task-s-uakeip-flag task-4-uakeup-flag) ) 

(SETQ PRI-1 (OR TASK -6-UAKEUP -FLAG 

(AND TASK-3-UAKEUP-FLAG 

(NOT TASK-S-UAKEUP-FLAG) (NOT TASK-444AKEUP-FLAG) ) 
(AND TASK-2-UAKEUP-FLAG 
,^^« ^. « ,«« ^ i^OT TASK-5-UAKEUP-FLAG) (NOT TASK.4-UAKEUP-FLAG) ) ) ) 
(SETQ PRI-8 (OR (AND TASK-5-UAKEUP-FLAG (NOT TASK-S-UAKEUP-FLAG)) 
(AND TASK-3-UAKEUP-FLAG 

(NOT TASK-6-UAKEUP-FLAG) (NOT TASK-4-UAKEUP-FLAG) ) 
(AND TASK-l-UAKEUP-FLAG (NOT TASK-S-UAKEUP-FLAG) 

(NOT TASK-4-44AKEUP-FLAG) (NOT TASK-2-UAKEUP-FLAG) ) ) ) 

(SETQ TASK-l-UAKEUP-FLAG iFeed into register 

_ (OR UAKEUP-1 (AND TASK -l-UAKEUP -FLAG INOT DI 
(SETQ TASK.2-UAKEUP-FLAG 

,r^,« ]05 UAKEUP-2 (AND TASK-2-WAKEUP-FLAG (NOT DISmSS-2)))) 
(SETQ TASK-S-UAKEUP-FLAG 

_ (OR UAKEUP-5 (AND TASK-5-UAKEUP-FLAG (NOT DISHISS-S) )) ) 
(SETQ TASK-B-UAKEUP-FLAG 

(OR UAKEUP-B (AND TASK-S-UAKEUP-FLAG (NOT DISniSS-B))))) 

; -»- nodeiLisp; Package:User; Base:10 *»- 

; PAL for SQTRAP irmv. 3) to encode trap address 

(DEFPAL SQTRAP PAL1SL8 

;; Inputs froa data path 

(iPIN 2 DP-TRANSPORT -TRAP L) 

(IPIN 3 DP-TYPE-TRAP) 

(IPIN 4 DP-niSC-TRAP) 

(IPIN 5 DP-SLOU-JUflP L) 

(IPIN B DP-TYPE-TRAP -NUn-1) ;Trap Param 1 

(IPIN 7 DP-TYPE-TRAP-NUn-8) ;Trap Parait 

;; Input froa aemory control 

(ipiN 8 nc-HAP-niss d 

|! Inputs froa sequencer 

(iPIN 9 U-NAF-1) 

(IPIN 11 U-NAF-e) 

(IPIN 13 SPY-ENABLE-TRAP) 

II Input froa clock 

(IPIN 1 CU -EXTRA- INNINGS) 

XI Outputs 

(Op IN 19 NEXT-CPC-l) 

(OP IN 12 NEXT.CPC-9) 

(OE 19 TAKE-TRAP-A) 

(DE 12 TAKE-TRAP-A) 

(OPIN 18 TRAP-TO-NAF L) . 

(OPIN 17 TRAP-SAVE-NPC L) 

(OPIN IB TAKE-TRAP) 

(IPIN IB TAKE-TRAP-A) ;Hack, Hack 

(OPIN 15 ANY-TRAP) 

(OPIN 14 TRAP.A-2) 



;Lou bits of trap address 



{Trap address select 
;Enable push on cstk 
{Branch to trap address 

;HOP this cycle 

;6it 2 of trap address (if not NAF) 



;; Priority encoding (in descending order) 

;; Highest: Transporter 

;; Type-trap (invisible pointer, bad arguaent) 

;; Misc Trap (aost traps, trap address froa NAF) 

St flap aiss 

XX Lowest! Slow juap (gc write trap) 
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(S£TQ TAICE-TRANSPORT-TRAP DP-TRANSPORT-TRAP) 

(5ETQ TAKE-TYPE-TRAP (AND DP-TYPE-TRAP (NOT DP-TRANSPORT-TRAP) ) ) 
_ (SETQ TA<E-NAF-TRAP (AND DP-HISC-TRAP (NOT DP-TRANSPORT-TRAP) (NOT DP -TYPE- TRAP) ) ) 
(SETQ TAKE-HAP-TRAP (AND nC-nAP-tllSS (NOT OP-niSC-TRAP) 

(NOT DP-TRANSPORT-TRAP) (NOT DP-TYPE-TRAP))) 
(SETQ TAKE-SLOU-JUflP (AND DP-SLOU-JUTIP (NOT DP-TRANSPORT-TRAP) (NOT DP-TYPE-TRAP) 

(NOT DP-niSC-TRAP) (NOT nC-flAP-niSS))) 

;: Decision whether to trap 

(SETQ ANY-TRAP (OR TAKE-TRANSPORT-TRAP TAKE-TYPE -TRAP TAKE-NAF-TRAP TAKE-HAP-TRAP) ) 

(SETQ TAKE-TRAP (AND (OR ANY-TRAP DP-SLOU-JUHP) SPY-ENABLE-TRAP CLK -EXTRA- INNINGS)) 

;; Save NPC if not trapping to NAF, •llouthg nicro instruct ion retru 
(SETQ TRAP-SAVE-NPC (AND TAKE-TRAP (NOT TRAP-TO-NAF))) 

;; Trap address computation 

(SETQ TRAP-TO-NAF (OR TAKE-NAF-TRAP TAKE-SLOU-JUHP)) 

(SETQ TRAP-A-2 TAKE -TYPE-TRAP) 

(SETQ NEXT-CPC-1 (COND (TAKE-TRANSPORT-TRAP HID 

(TAKE-TYPE-TRAP DP-TYPE-TRAP-NUtt-l) 

(TRAP-TO-NAF U-NAF-1) 

(TAKE-nAP-TRAP NIL))) 
(SETQ NEXT-CPC-0 (COND (TAKE-TRANSPORT-TRAP NIL) 

(TAKE-TYPE-TRAP DP-TYPE-TRAP-NUn-B) 

(TRAP-TO-NAF U-NAF-0) 

(TAKE-riAP-TRAP T)))) 

; -«- rtoderLitp; PackageiUser; Base: 18 -«- 



(DEFPAL SQDCOn PAL1BL8 


(IPIN 18 SPY-ADOR-S) 


(IPIN 17 SPY-READ-DP- ID L) 


(IPIN 1 U-COND-FUNC-1) 


(IPIN 2 U-CONO-FUNC-0) 


(IP N 3 U-rtAGIC-l) 


( PIN 4 U-nAGIC-8) 


(IPIN S SPEC-NPC-riAGIC L) 


(IPIN 6 nC-UAIT L) 


(IPIN 7 TAKE-TRAP L) 


(IPIN 8 NOP L) 


(IPIN 9 SPY-READ L) 



(IPIN 11 SPY-URITE L) 

(OPIN 16 SHOULD-SKIP) 
(OPIN 15 NPC-nUX-EN L) 
(OPIN 14 NPC-XCV-EN L) 
(OPIN 13 NPC-XHT-EN L) 
(OPIN IS NPC-SEL-1) 
((FIN 12 SPY-XCV-EN L) 

(FIELD OAGIC U-flAGIC-l U-HAGIC-B) 

;; Control for spy bus buffer 
(SETQ SPY-XCV-EN TOR SPY-URiTE 

(AND SPY-READ (NOT SPY-ADDR-5) (NOT SPY-REAO-DP-ID) ) ) ) 

IJL§!^'E 1^ ^ ^^^^^ ^U*^ • i ""d not trapping 

(SETQ SHOULD-SKIP (AND (FIELD U-COND-fDnC-I U-COND-FUNC-0 1) (NOT TAKE-TRAP))) 

;; Controls for the NPC input aux and the NPC to/fro« Lbus data path 

li^§£*!lSl alternate NPC inputs if special function or trap 
(SETQ NPC-SEL-1 (OR SPEC-NPC-HAGIC TAKE-TRAP)) ^ 

;: Special functions 

Ml^ NPC-pUX-TO-LBUS (AND SPEC-NPC-flAGIC (FIELD HAGIC 1))) 

(SETQ NPC-FROn-LBUS (AND SPEC-NPC-ttAGIC (FIELD flAGIC 2))) 

\km}^lt1^^ll^'^^^^^ "^* *° ^^'^•' ^"^ inadvertentlu. 

{SETQ DRIVE-LBUS (AND NPC-HUX-TO-LBUS (NOT HC-UAIT) (NOT NOP))) 
(SETQ NPC-XCV-EN (OR DRIVE-LBUS NPC-FROH-LBUS) ) 
(SETQ NPC-XriT-EN DRIVE-LBUS)) 

: -«- f1ode:Liep; PackagorUser; Base:10 -»- 



(DEFPAL 


SQDCOD PALI ELS 




(IPIN 


18 SPY-ADlV1-S> 




( PIN 


17 SPY-READ-DP- ID L) 


(IPIN 


1 U-COND-rUUC-l) 




(IPIN 


2 U-COND-FUNC-0) 




(IPIN 


3 U-MAGiC-l) 




(IPIN 4 U-rAGiC-a) 




(IPIN 


5 SrEC-NPC-riAGIC 


L) 


(IPIN 6 nC-*JAIT L) 




(IPIN 


7 TAKE-TRAP L) 




(IPIN 


8 NO? L) 




(IPIN 


9 SPY-READ L) 




(IPIN 


11 SPY-URITE L) 
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(OPIN IG SHOULD-S*CIP) 

iOPiu 15 r4PC-nux-Ef^ l) 

(OPJN 14 WPC-XCV-EN L) 
(OPiN 13 fJPC-Xni.EN L) 
<OPIN 19 NPC-SEL-1? 
(DPIN 12 SPy-XCV.EN L) 

(FIELD riAGIC U-nAGIC-1 U-HAGIC-e) 

;; Control for spy bus buffer 
(SETQ SPY-XCV-EN TOR SPY-URITE 

(Ar>rO SPY-READ imi SPY-ADDR-S) (not SPY-READ-DP-ID)))) 

;: Skip if U COND PJNC - 1 and not trapptng 

(§ETQ &<OULD-S<IP (AND (FIELD U-C%D-FOfiC-I U-C:0ND-FUNC-8 1) (f«T TAKE-TRAP))) 

;; Controls for the NPC input »ux and the ^PC to/fpo« Lbus data path 

;: Select alternate ^'PC tnouts jf special function or trap 
(SETU NPC-SEL-l (OR SPEC-KPC-HAGIC TAKE-TRA;^)) 

t; Special functions 

(§ETQ NPC-nuX-TO-LBUS (AND SPEC-rPC-HAGIC (FIELD flAGIC 1))) 

(SETQ ^iPC-FRa*1-LBUS (AND SPEC-r4PC-nAGIC (FIELD ttAGIC 2))) 

j; Various tri state enables. Be careful not to drive bus inadvertently* 

{§ETa NPC-rrjX-EN (not t;PC-FROn-LBUS)) 

(SETQ DRIVE -LBU3 (AlC NPC-MUX-TO-LBUS (NOT nC-liAIT) (NCT NOP))) 

(SETQ NPC-XCV-EN (OR DRIVE-LBUS NPC-FROn-LBUS) ) 

(SETQ NPC-XHT-EN DRIVE-LBUS)) 



DP - PAL 

t-*- Mode: LISP; Package: USER; Base: 18 -«- 

: SPAL on DPSttC — control* tha BYTE S selection 

;Bute Function 1 Bagict 

: *2 - I -> S-17 

I 02 m B m> S«37 unlata #-13 in uhich case S>17 

(DEFPAL SPAL PALISLS 

(IPIN 2 SREG-4) J Input* for high bit mux 

(IPIN 3 U-AnUA-9) i H • Tor n.^n 

(IPIN 4 U-COND-SEL^) 

ll^l?! i tZ^l'dl] '-'''''" '"'^'^ ^'"'^ 

(IPIN 7 U-MAGIC-l) 

(IPIN 8 U-nAGIC-0) 

(IPIN 9 U-BYTE-F-1) jBute Function field 

(IPIN 11 U-BYTE-F-0) ^ runc^ion TieiG 

(FIELD flAGIC U-nAGIC-3 U-HAGIC-Z U-ttAGIC-l U-nAGIC-B) 
(FIELD CASE U-HAGIC-l U.rWGIC-0) u-n«uiu oj 

(FIELD BYTE-F U-BYTE-F-l U-BYTE-F-0} 

JSSIK }§ i!l|-H} »"'0^ bit output 

(OPIN 17 BYTE-S-3) jLou bits out with constants 

(OPIN 16 BYTE.S.2) constants 

(OPIN 15 BYTE-S-1) 

(OPIN 14 BYTE-S-B) 

(OpIn ii IiIIlIi) ^""*' ""*'"''* ^"""^ '°" 4 S bits 

(OPIN 12 S-SEL-0} 

(OE is i-lELli) ? Output enable for low bits 

(OE 15 S-SEL-2) 
(OE 14 S-SEL-2) 

(SETQ CONSTANT-S (FIELD BYTE-F (0 1))) 

SETQ USE-SREG (AND (FIELD BYTE-F 3) (FIELD CASE 2))) 

SETQ USE-AHUA (AND (FIELD BYTE-F 3) (FIELD CASE 0))) 
(SETQ USE-INST (AND (FIELD BYTE-F 3) (FIELD CASE 3)) 
(SETQ USE-CONO (OR (AND (FIELD BYTE-F 3) (FIELD CASE D) 

(FIELD BYTE-F 2))) 
(SETQ S-SEL-2 CONSTANT-S) ;PAL generates the constants 

(SETQ S-SEL-1 (OR USE-INST USE-COND)) B»"eraxes ine constants 
(SETQ S-SEL.0 (OR USE-AflUA USE-CONO)) 

(SETQ BYTE-S-4 (COND (USE-SREG SREG-4) 

(USE-AnUA U-AnUA-9) 
(USE-CONO U-COND-SEL-4) 
(USE-|NST_U-C0N0-SEL-4) ;Onlg 8 INST bits! 

(OR (FlLo BYTE-F 0) ;37 

(AND (FIELD BYTE-F 1) 37 except for... 

(NOT (OR (FIELD MAGIC ^pl3) ;I7 for' these 

recrn ovtc a rt tx U-nAGIC-2) ) ) ) ) ) ) 

(SETQ BYTE S 2 T) **"°" ^ always on in constants for now 

(SETQ BYTE-Sll T) 
(SETQ BYTE-S-0 T)) 
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;-«- node:LI5Pt Package:USER; Ba8e:10 -«- 

; SHFnSK on DP^HnK 

; Special aodified version for lou 2 bitt 

; If ALUB-SIGN-HACX it on, and you LDB out the sign bit, 

; then gou get the cospteaent o? the eign bit instead. 



1236 



(DEFPAL SHFnS<0 PAL1SL8 
(IPIN 18 SH-N+2} 
(IPIN 17 SH-N+1) 
(IPIN IS SH-N) 
(IPIN 15 SH-N-1) 
(IPIN 14 SH-N-2) 
(IPIN 2 XBUS-N+2) 
(IPIN 3 XBUS-N+1) 
(IPIN 5 nAS<-N+2) 
(IPIN 6 nAS<-N+l) 
(IPIN 7 ALUB-SIGN-HAOC L) 
(IPIN 8 Rl) 
(IPIN 9 Re) 
(IPIN 11 HERGE) 
(OPIN 13 ALUB-N+2) 
(OP IN 19 ALUB-N+1) 



; Inputs froa shifter 

; Inputs to verge 

; Inputs froa aask proa 

$Lou bits of rotate aaount 

iUse XBUS (1) or (0) ae background 
;Outputs 



(5ETQ ALUB-N+1 

(COND ((NOT riASJCN+l) (AND MERGE XBUS-N+D) 

((AfC nAS*C-N+i (NOT Rl) (NOT RB) ) SH-N+1) 



((AND riASK-N+l 
(NOT Rl) 



(NOT ALUB-SIGN-HACO 

--. ._. Re) SH-N) 
((AND RASK-N+l ALUB-SIGN-HACX 

(NOT Rl) Re) (NOT SH-N)) 
((AND HASK-N+l Rl (NOT Re)) SH-N-l) 
((AND riASK-N+l Rl Re) SH-N-2)}) 

(SETQ ALUB-N+2 

(COND ((NOT flASIC-N+2) (AND MERGE XBUS-N+2)) 

((AND nASK-N+2 (NOT Rl) (NOT RS) ) SH-N+2) 
((AND nASK-N+2 (KOT Rl) RS) SH-N+l) 
((AND nAS<-N+2 Rl (NOT RB) ) SH-N) 
((AND rtASK-N+2 Rl R0) SH-N-1))}) 

;-«- riodeiLISP; PackagerlSER; Base:le -»- 
; SHFnSiC on DPShHK 



: Background 
;Unshifted data 
;Shift left 1 noraal 

;Shift left 1 hacked 

;Shift left 2 
;Shift left 3 



iB background 
jUnshif ted data 
;Sh(ft left 1 
;Shift left 2 
;Shift left 3 



(DEFPAL 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(IPIN 
(OPIN 
(OPIN 
(OPIN 



SHRISK PALIBLS 

18 SH-N+2) 

17 SH-N+l) 

IS SH-N) 

15 SH-N-1) 

14 SH-N-2) 

" SH-N-3) 
XBUS-N+2) 
XBUS-N+1) 
XBUS-N) 
nAS<-N+2) 
HASK-N+l) 
MASK-N) 



8 Rl) 

9 R0) 

11 MERGE) 

13 ALUB-N+2) 
IS ALUB-N+l) 

12 ALUB-N) 



{Inputs froa shitler 

; Inputs to aerge 
{Inputs froB nask proa 

sLou bits of rotate aaount 

{Use XBUS (1) or 8 (8) as background 
{Outputs 



(SETQ ALUB-N 

(COND ((NOT MASK-N) 
((AND flASK-N 
((AND rtASiC-N 



(AND rERGE XBUS-N)) 
(NOT Rl) (NOT R3)) SH-N) 
(NOT Rl) R0) SH-N-1) 
((AND HASK-N Rl (NOT R0)> SH-N-2) 
((AND HASK-N Rl RB) SH-N-3))) 



{Background 
{Unshifted data 
{Shift left 1 
{Shift left 2 
{Shift left 3 



(SETQ ALUB-N+l 

(COND ((NOT HASJC-N+l) (AND MERGE XBUS-N+1 )) 

((AND MAS<.N+1 (NOT Rl) (NOT R0)) SH-N+l) 
((AND MASK-N+1 (NOT Rl) R8) SH-N) 
((AND MASK-N+l Rl (NOT RB) ) SH-N-l) 
((AND MASK-N+1 Rl RB) SH-N-2))) 

(SETQ ALUB-N+2 

(COND ((NOT MASIC-N+2) (AND MERGE XBUS-N+2}) 

((AND nASK-N+2 (NOT Rl) (NOT R8) ) SH-N+2) 
((AND MASI(:.N+2 (NOT Rl) RB) SH-N+l) 
((AND nASK-N+2 Rl (NOT RB) ) SH-N) 
((AND nASK-N+2 Rl RB) SH-N-1)))) 

*"5r "od^sLISP; PackageiUSERj BasexlB -»- 
: RREG on OPSMC (for the rev-3 board) 



;C(ock enable 
{Source select 
{Dispatch (array type) 



{Background 
{Unshifted data 
{Shift left 1 
{Shift left 2 
{Shift left 3 



{0 background 
{Unshifted data 
{Shift left 1 
{Shift left 2 
{Shift left 3 



ILIbl-PAL RREG PALIBRS 


(IPIN 19 LOAD L) 


(IPIN 12 FROn-DISP) 


(IPIN 2 DISP-2 L) 


(IPIN 3 DISP-l L) 


(IPIN 4 DlSP-a L) 
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(IPIN 
(IPIN 



OBUS-4) 

0BUS.3) 
OBUS-2) 



(IPIN 8 OBUS-1) 

(IPIN 9 OBUS-B) 

CRPIN 17 R-4) 

(RPIN 16 R-3) 

(RPIN 15 R-2) 

{RPIN 14 R-1) 

(RPIN 13 R-8) 
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{Output bus 
{Registered outputs 



1238 



;Decod« of control field 

(SETQ HXD (NOT LOAD)) 

(SETQ LOAD-OBUS (ANO LOAD (NOT FROH-DISP))) 

(SETQ LOAO-DISP (ANO LOAD FROH-DISP)) 

;Load register from self, obus, or func(disp) 
(SETQ R-e (COC (HOLO R-8) 

(LOAD-OBUS OBUS-B) 

(LOAD-DISP (FIELD OlSP-2 DISP-l DISP-8 (824))))) 
(SETQ R-l iCOHD (HOLO R-1) 

(LOAD-OBUS OBUS-l) 

(LOAO-DISP (FIELD DISP-2 DISP-1 DISP-8 (834))))) 
(SETQ R-2 (COND (HOLO R.2) 

(LOAD-OBUS 0BUS.2) 

(LOAD-OISP (FIELD DISP.2 OISP-1 DISP-8 (12 3 4))))) 
(SETQ R-3 (COND (HOLO R-3) 

(LOAD-OBUS OBUS-3) 

(LOAD-DISP (FIELD DISP-2 DISP-1 DISP-8 (8123 4))))) 
(SETQ R-4 (COND (HOLO R-4) 

(LOAD-OBUS OBUS-4) 

(LOAD-OISP (FIELD DISP-2 DISP-l DISP-B (8 12 3 4)))))) 

t-«- noderLISP: Package:USER; Base:18 -«- 

; RPAL on OPSHC — controls the BYTE R selection 



I Bute Function 1 aagict 
; jy2 - 1 -> R-28, t3 - 
; ir2 • 8 •> 



rotate-»«sk 



03 -> 28 bit of R 

-<ri -> 16 bits of R 

-#8 -> 81 bit of R 

Thus: 

8 -> 17 1 -> IS 2 -> 1 

18 -> 37 11 -> 3B 12 -> 21 

Only codes 2, 3, 18, and 13 Mre used I believe 



3 -> 8 
13 -> 28 



CCEFPAL RPAL PAL1SL8 
(IPIN 2 RREG*4) 
(IPIN 3 U-Af1UA-4) 
(IPIN 4 INST-4) 
(IPIN 5 U-nAGIC-3) 
(IPIN 6 U-nAGIC-2) 
(IPIN 7 U-riAGIC-l) 
(IPIN 8 U-nAGIC-8) 
(IPIN 9 U-BYTE-F-1) 
(IPIN 11 U-BYTE-F.8) 



{Inputs for high bit mux 
tflagic nuMber field 

;Byte Function field 



(FIELD RAGIC U-nAGIC-3 U-nAGIC-2 U-TlAGIC-l U-HAGIC-B) 
(FIELD CASE U-nAGIC-l U-MAGIC-B) 
(FIELD BYTE-F U-BYTE-F-1 U-BYTE-F-8) 



(OPIN 18 BYTE-nERGE> 
(OPIN 17 ROTATE -MASX:) 
(OPIN 16 BYTE-R-4 L) 
(OPIN 15 BYTE-R.4) 
(OPIN 14 R-PAL-1-3) 
(OPIN 13 R-PAL-8) 
(OPIN 19 R-SEL-1) 
(OPIN 12 R-SEL-8) 



{Background fro» Xbus 

xHlgh bit output 

{Bits 1-3 of constants 

;B1 t 8 of constants 

{Mux control for lou 4 R bits 



(SETQ CONSTANT-R (FIELD BYTE-F (8 1 2))) 

(SETQ USE-RREG (AND (FIELD BYTE-F 3) (FIELD CASE (1 2)))) 

(SETQ USE-AHUA (AND (FIELD BYTE-F 3) (FIELD CASE 8))) 

(SETQ USE-INST (AND (FIELD BYTE-F 3) (FIELD -CASE 3))) 

(SETQ R-SEL-1 (OR USE-INST CONSTANT-R)) 

(SETQ R-SEL-8 (OR USE-AflUA CONSTANT-R)) 

(SETQ BYTE-nERGE (AND (FIELD BYTE-F 3) U-nAGIC-2)) 
(SETQ ROTATE-ttASK (COND ((FIELD BYTE-F 3) U-nAGIC-3) 

((FIELD BYTE-F 1) 
(OR (AND U-nAGIC-2 U-ttAGIC-S) 
(FIELD nAGIC JSTolS))))) 

(SETQ BYTE-R-4 (COND (USE-RREG RREG-4) 
(USE-AnUA U-AnUA-4) 
(USE-INST INST.4) 
(CONSTANT-R 

(ANO (FIELD BYTE-F 1) 

(OR U-nAGIC-3 U-nAGIC-2))))) 

(SETQ R.PAL-8 (ANO (FIELD BYTE-F 1) (NOT U-nAGlC-2) (NOT U-nAGIC-BUl 
(SETQ R-PAL-1-3 (ANO (FIELD BYTE-F 1) (NOT U-nAGIC-2) (NOT U-nAGIC-D) )) 
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; -«- flode:Li8p; Packagc:User; Base: 10 -«- 

; PALtf2 for DPOCOO 

; Decodes ■iacel laneoue epecial functions, Boatly for the ALU. 

(DEFPAL DPDC0D2 PALIBLS 

(OPIN 18 UEIRD-ALU-FCN) xSelect second eet of IE AIM fr.nr"+i««- 

(OPIN 17 TRAP-IF-BBUS-NOT-FIXNUn) To DPTRAP pHnt functions 

(OPIN 16 TRAP-IF-TYPE-COND) To DPTRAP pp nt 

(OPIN 15 TEST-ANY-STACIC) To DPGC print 

(OPIN 14 TEST-OTHER-STACK) To DPGC print 

(OPIN 19 EXTENDED-BMUA L) To DPSHA print 

(OPIN 12 nPY-TO-XBUS L) j To DPttPY print 

(IPIN 3 uInAGIC-2) Sttaglc-number field, extends spec func 

(IPIN 4 U-nAGIC-1) 
(IPIN 5 U-nAGIC-0) 

(IPIN 6 U-SPEC-4) iSpeciat function field 

(IPIN 7 U-SPEC-3) .special xunciion neid 

(IPIN 8 U-SPEC-2) 
(IPIN 9 U-SPEC-1) 
(IPIN 11 U-SPEC-e) 

(FIELD SPEC U-SPEC-4 U-SPEC-3 U-SPEC-2 U-SPEC-1 U-SPEC-0) 
(FIELD MAGIC U-nAGIC-3 U^GIC.2 U-fUGIC-l U-nAGIC-0) 

(SETQ ARITHPIETIC-nAGIC (FIELD SPEC <ro(10 30))) 

(SETQ UEIRD-ALU-FCN (AND ARITfrETIC-HAGlC S-AaGIC-2) ) 

;: Type checking 

(SETS TRAP-IF-BBUS-NOT-FlXNUn (OR (AND ARITHnETIC-HAGIC U-HAGIC-l) 

(SETQ TRAP-IF-TYPE-COND (OR (AND ARITHHETfc^nAGIC^U-nAGI^ 

(FIELD SPEC ;:ro(ll 12 13)))) 

;: Miscellaneous decodes 

(SETQ CROCKS (FIELD SPEC tfoU)) 

5 SETQ GC-CROC<S (AND CROCKS (NOT U-riAGIC-3) ) ) - 

iilR JiiI-Ay:t§^^^*^.^A^° GC-CROCKS U-riAGIC-0)) 

1119 JSIJr5Jy^^-STAC< (AND GC-CROCKS U-HAGIC-l)) 
(SETQ EXTENDED-SnUA (AND CROCKS (FIELD flAGIC ^ol0))) 

(SETQ MULTIPLY (FIELD SPEC #o(13 17))) 

(SETQ MPY-TO-XBUS (AND MULTIPLY (NOT U-MAGIC-1) U-MAGIC-2))) 

; -«- ttode:Li«p: Package:User; Ba8e:10--«- 

; PALn for DPDCOO 

; Generates ALU control tignats for overflow, and decodes spec field. 

I AiBost all of the spec field decodes are in the other PAL now, whore 

J they can see the ■agic-number field, wnor» 

(DEFPAL DPOCODl PAL16L8 
5,1-?P^'='*' function section 
(6Plf3 18 ALUB-SIGN-HACK L) 
(OPIN 17 MULTIPLY L) 
(OPIN 16 CRXKS-TO-YBUS L) ;To DPYSL2 print 

(IPIN 6 U-SPEC-4) sSoecial function field 

(IPIN 7 U-SPEC-3) .opeciai runciion field 

(IPIN 8 U-SPEC-2) 
(IPIN 9 U-SPEC-1) 
(IPIN 11 U-SPEC-0) 

(FIELD SPEC U-SPEC-4 U-SPEC-3 U-SPEC-2 U-SPEC-1 U-SPEC-0) 

SETQ ALUB-SIGN-HACK (FIELD SPEC SolS) ) 5PfcC-0) 

SETQ pULTIPLY (FIELD SPEC #0(13 17)) 
(SETQ CROCKS-TO-YBUS (FIELD SPEC J^olS)) 

;: ALU Overflow Controls 

OP N 12 nvFL J\ ^ *^H ^""c^ion to overflow calculator 

CtFIN 12 OVFL-F L) ,ALU wants both senses at equal speed 

(IPIN 1 ALUB-31) 
(IPIN 2 XBUS-31) 

(IPIN 4 ALUf'i) ^°I!l^ l°?^^* l^S" *"? g'*« °^ ^U fen, since 

P w t trIp ic_nvt:oci mn '2'^*^ A+I , A-1, A+B, and A-B work anyway. 
(IPIN 5 TRAP-IF-OVERFLOU) ^Microcode enable for overflow checking 

(SETQ ADO (FIELD ALtF-2 ALUF-1 D) 

SETQ SUB (FIELD ALUF-2 ALUF-1 2)) 

(SETQ INC (FIELD ALUF-2 ALUF-1 

(SETQ DEC (FIELD ALUF-2 ALUF-1 3)) 

(SETQ SIGNS-DIFFER (OR (AND (NOT XBUS-Sl) ALUB-31) 

(AND XBUS-31 (NOT ALUB-31)))) 

(SETQ ENABLE (AND TRAP-IF-OVERFLOU 

(OR (AND ADO (NOT SIGNS-DIFFER)) 
(ANO^IUB^SIGNS-DIFFER, 
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tS«lact EQV (function G3) if overflow check enabled 
:|ejcct SETO ji^""p^{on 71) if overflow check not enabled 

t *«- nodetLiep; Package: User t Base: 18 -»* 

I PAL for DPBAS4 to^o^'^^rate various base regiatep control aignale 
; Um uith the rmv,3 board 

(DB=PAL BASECTL PAL1BL8 

J2EIH J5 H"§IS"5^§^} ^^•^ W^^*« "»»« etack-potnter as base 

lOPIN 17 U-FRflP-BASE) j ». uees frawe-po/nter 

WPIN IS U-INST-STICP) , ,. uses stack-pointer, selected by INST 

ifwifu «r 4M-M ^w>r^^ ** htncs gcnerste carry into adder 

^*EH'J5>*rS"-*^^^^ 5This cycle writing Amei» 

; (OPIN 14 NC) snot used 

J9£!H \l ^y|"9E^?SAS°. V^ lEnable input to cone from ecmory control 
£ K }? ?^l*JS"!iHI H »U-R-BASE-§ selects stack- or fraae-pointer 
(OPIN 12 AnEfl-TO-ASUS L) ;A fteaory is Abus source 

HpIn 2 IwiliAil'e) ^^■•" "^'** ^•••-^•5'»*«'" ••'•ct 

;i?^?NW.i?giil^) ,not use!.'"" ^"^ base-register .elect 

ii?ia I t'^t^zii ''' ' -^^^"^ "'-^ 

ftolS I ifSI"?Z A-.r« . . «?'0" ^'* «>^ aacro instruct ion offset 

! D S S fP92.'li^^Lt^ . »t^"« 'ddress »aps into Aeea 

!J£!S ?.^rJ^72^-*^^ *-^ «<^"«" *^»*» •ddress select -> Lbua address 

llPIN XI HOP U ;Inhibtt uriting froa this instruction 

tSETQ U-INST-STICP (AND (FIELD U-U-SASE-l U-U-BASE-0 3) IInJST-7)) 
(SETQ U-INST-FRflP (AND {FIELD U-W-BAsl-l uIu-BASE-0 3 (NOT IhlST-7)}) 

(SETQ U-FRnP-BASE (OR (FIELD U-U-BASE-l U-U-BASE-8 1) U-INST-FRHP)) 



t A* — ig-ite IS on unless wr i ta-addrees is aLbus-addr, in which case it ie enabled 

i&TS".2?2^.'5T?P^,ftSS'"':ii!-*"®"'- ^'«o '* »• inhibited by NOP. 
(SeiQ Artn-t«ITE (NOT (OR (AND U-AttUA-SEL-PflA 

(NOT (AND ADOR-IN-ATIEn U-U-BASE-l))) 
NOP))) 

(SETQ AnRA-SEL-«AOOR (FIELD U-AHRA-SEL-l U-AHRA-SEL-B D) 
(SETQ AfRA-SEL-BASE (FIELD U-AHRA-SEL-l U-AnRA-SEL-B 3)) 

(SETQ AHEn-TD-ABUS (COND (Ar«A-SEL-«ADOR ADOR-IN-AMEn) 

,.^^ ^ ^ ^^ ^ ^^^T AflRA-SEL-aADDR) (NOT AflRA-Sa-BASE)))) 

(SETQ BASE-TO-ABUS (AND AHRA-SEL-BASE (NOT U-R-BASE-1))) 

(SETQ ABUS-OFFBOARD (OR (AND AHRA-SEL-BASE U-R-BASE-l) 

(AND AnRA-S£L-«ADDR (NOT ADOR-IN-ATtEn)) )) ) 

; -«- node:Ltsp; PackagesUser; Ba3e:8 -«- 

; Prograa to aaka the aask proas. Sane package as PKOMP. 

{Arrays containing the rS7138H data 
(defvar aaskd (aake-array 2848. *:type *art-8b}} 
(defvar aaskl («akc-array 2848. ' : type 'ert-8bn 
(defvar «ask2 (aake-array 2848. 'ttype *apt-Sbn 
(defvar aaskS (Mke-array 2848. ' : type 'art-8b)) 

m 

(declare (fixnua are rotate value aask)) 

m 

(defaacro <• (argl arg2 Arest aore-args) 

(cond ((null aore-args) Mnot {> .argl ,ara2})) 
(t '(and (not i> ,argl ,arg2)) 

(<- .arg2 . ,«ore-arg8) )))) 

(defun store-aask (r s rotate value) 

(or (<« 8 r 37) (ferror nil "-^S bad value for R" r)) 

(or (<« 8 s 37) (ferror nil *-^S bad value for S* s)) 

(or (<- 8 rotate 1) (ferror nil "-^S bad value for Rotate-flask" rotate)) 

(let ((adr (+ r (Ish rotate 5) (Ish s 6)))) 

(aset (Idb 8818 value) aaskB adr) 

(aset (Idb 1818 value) aaskl adr) 

(aset (Idb 2818 value) ■ask2 adr) 

(aset (Idb 3818 value) aask3 adr))) 

(defun fetch-eask (r s rotate) 

(or (<- 8 r 37) (ferror nil "-^S bad value for R" r)) 
(or (<- 8 s 37) (ferror nil "*rS bad value for S" s) ) 
(or (<- 8 rotate 1) (ferror nil "-^5 bad value for Rotate-Hask" rotate)) 
(let ((adr (+ r (Ish rotate 51 ttsh s BJ))} 
(dpb (aref mask3 adr) 2010 

(dpb (aref waskZ adr) 2818 

(dpb (aref naskl adr) 1018 
(aref saskB adr)))))) 



4,887,235 
1243 1244 

(defun setup-wask-proBS 

- ;The unrotated sasks are siaple enough 

f (loop for 8 from to 37 

as mask - 1 then (U (« aask 2)) 
do (loop for r from 8 to 37 

do (store-mask r e mask))) 
;Thc rotated masks provide for wrap-around bytes, probably unnecessary 
(loop for 8 from to 37 

as ifiask - 1 then (1+ (« mask 2)) 
do (loop for r from to 37 

as ■ - aask then (+ (logand UAl^ 1.32.) (» ■ 2)) 

(tdb 3701 ■)) 
do (store-aask r % 1 si)))) 

Isetup-ftask-proffls) 

Function to print them out since we can't prograa the» ourselves right now. 
idefun pr int-mask-proms (file &au»c (base S)) 
(wi th-open-f \ le (standard-output f f It * tprvnt) 
(loop for prom in * (maskS maskl mask2 mask3) 

do (format t "-'A Prom:-^2X^15<Qctal Location*'>-15<Hex Locatton*>'%15<0ctal 
Content8*>*15<Hex Contents* 
(setq prom (surrevaT prom) ) 
(dotimcs (i 2048.) 

(format t --.150-12X" i) 
(hex-print i 3) 

(format t "-vl50-13X'' (aref prom i)) 
(hex-print (aref prom i ) 2) 
(terpri)) 
(tyo ;sr\page)})) 

(defun hex-print (number n-digits) 
(loop repeat n-digits 

as divisor • (^ IS. (1- n-digitsH then (// divisor IB.) 
do (tyo (nth i\ (// number divisor) 16.) 

• iuj^ nj\ n/2 n/2 uik «f/5 #/s nn n/z n/s u/k tt/B tt/c tf/u #/E #/F))))) 

What is claimed is: 30 steps of referencing the tables is performed in parallel 

1. In a method of data processing in a processor pro- with writing into memory. 

grammable in a symbolic programming language of the 4. The method according to claim 1, wherein the step 
type including LISP and having automatic memory of adding comprises setting a bit in a table indexed by at 
reclamation, wherein the processor repeatedly apphes least some bits of the address being written, 
address words to gain memory to write data structures 5. The method according to claim 1, further compris- 
into main memory and read data structures from main ing separating main space into pages of memory, writ- 
memory to perform operations thereon, and the proces- ing pages of memory into a secondary storage device, 
sor allocates previously used portions of main memory scanning each page of memory when written into the 
for writing data structures by reclaiming same, the im- 40 secondary storage device to see if the page contains a 
provement wherein the step of reclaiming comprises: pomter to secondary space, updating an associated data 

a. defining address regions in main memory includmg structure to indicate for each page when a pointer to 
a main space and a relatively smaller subsidiary subsidiary space is present, thereafter reclaiming subsid- 
^P^^^' iary space by copying the data structures pointed to by 

b. writing new data structures into subsidiary space 45 ^he pointers of the indicated pages. 

until It is full; and u •* • <• n u «• The method according to claim 1, further compris- 

c. reclamung subsidiary space when it is full by . e > f 
i. detecting the writing of a data structure into main ^^^} ... , . ... 

space having a pointe into subsidiary space; ' '^^^'^.8 three address regions m the mam space m- 

ii. adding memory locations of pointer detected in 50 ^^"/"^S ^ °^^ ^P^"^^' ^ <^°Py ^^^"^ ^""^ ^ "*^ ^P^=^! 

step (i) to a given data structure; ^. . ,, . • , j j. 

iii. halting operation of the processor; reclaumng old space durmg the repeated readmg and 

iv. locating all pointers to subsidiary space by refer- , ^"t"*? ^y. *« P^Pf ^'°^ ^ . u u 

encing the given data structure; detemumng if an address desired by the processor is 

V. locating useful data structures in subsidiary 55 •" od space by examimng the address word m 

space from the pointers located in step (iv) and; P^^^^ "^'^^ ^PPly™g ^he address word to main 

vi. copying the located useful data structures into '°«'°°'y and producmg a trap if the address corre- 

main space until there are no further pointers ^P"""^^ *« °1^ SP^=« ^'^' "^ *« ^^l « produced, 

into subsidiary space. '^opyi^S the data structure associated with the ad- 

-i-m. 4.1. J J- * 1- 1 1. ■ ^u a\ dress mto a new address in copy space and writing 

2. The method accordmg to claim 1, wherem the 60 • ^ • .. ^i. j j ■ i j • j- ..• 

-, .,".. .. a pomter mto the address m old space indicating 

operation of detectmg the wntmg of a pomter com- ^^^ ^^^ ^^^^^^3 ^ ^^p^ ^^^^^ ^^^ 

pnses referencmg a table of addresses mdexed by at accessingeachaddressincopy space to see if the data 

least some bits of the location being written to indicate structure therem has a pomter to old space and if 

if the address is in main space and referencing a table of g- such pointer is present, moving the data structure 

addresses indexed by at least some bits of the contents of from old space to a new address in copy space and 

the pointer being written to indicate if the pointer bemg updating the data structure of the accessed address 

written is a pointer to subsidiary space. ^ ^^PV ^pace to include a pointer to the new ad- 

3. The method according to claun 2, wherein the ^^^^^ '^ ^^P^ sP/*=^^ ^ ^ ^ 



